Sub發郵件及開啟網址()
    If MsgBox("現在發送郵件!"&Chr(10)&"選是發送，選否退出！",vbYesNo+64,
        "郵件")=vbYes Then
    ActiveWorkbook.FollowHyperlink "maiLTo:andy_qc@163.com"
    End If
    If MsgBox("現在登錄163網頁!" & Chr(10) & "選是登錄，選否退出！", vbYesNo
    ActiveWorkbook.FollowHyperlink "http://news.163.com"
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Application.EnableEvents=False      '禁用事件
  On Error Resume Next                '出錯時繼續執行
    ActiveSheet.DrawingObjects.Delete    '刪除產生的對象
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                                        '將選項復制為圖片
    Target.Cells(1, 1).Offset(0, 2).Select           '將光標移到后兩列
    ActiveSheet.Pictures.Paste.Select
    With Selection.ShapeRange
      .ScaleWidth 2, msoFalse, msoScaleFromTopLeft
                                  '將圖片增大三倍，可以自己調整
      .ScaleHeight 2, msoFalse, msoScaleFromTopLeft
      .Fill.ForeColor.SchemeColor=3           '設置前景填充色
    End With
    Target.Activate                           '激活單元格
    Application.EnableEvents=True               '恢復事件
End Sub

Sub不重復隨機數()
  Dim arr1&(1 To 10000, 1 To 1), arr2(1 To 10000) As Boolean, k&, m&
  [a:a].Clear
  Randomize
  m=0
  Do While m < 10000
    k=Int(10000 * Rnd)+1
    If Not arr2(k) Then
      m=m+1
      arr1(m, 1)=k
      arr2(k)=True
    End If
  Loop
  [a:a]=arr1
  [a:a].NumberFormatLocal="0000"
 End Sub

Sub將有分隔樣式之數據轉為下拉列表()
    For i=3 To [b1048576].End(xlUp).Row
    x=Replace(Cells(i, 2), "/", ",") '將分隔符/替換為逗號
    Cells(i, 3).Clear               '清除第三列所有數據信息
    With Cells(i, 3).Validation      '為第三列添加數據有效性下拉列表
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=_
      xlBetween, Formula1:=x
    End With
    Next i
End Sub

Sub帶圈編號()
Dim row1 As Integer, row2 As Integer, fontsize As Byte, ZT As String
On Error GoTo err
If Selection.Cells.Count=1 Then
row1=InputBox("請輸入填充起始號", "序號", 1)
row2=InputBox("請輸入填充終止號", "序號", 10)
fontsize=InputBox("請輸入序號之字體大小", "字號", 10)
ZT=InputBox("請輸入序號之字體" & Chr(10) & "若單元格較小，請用宋體！", "字體",
    "Impact")
Application.ScreenUpdating=False
For i=row1 To row2
    ActiveSheet.Shapes.AddShape(msoShapeOval, Selection.Left,
        Selection.Top, Selection.Width, Selection.Height).Select
    Selection.Characters.Text=i
    With Selection.Characters(Start:=1, Length:=Len(i)).Font
      .Name=ZT
      .Size=fontsize
    End With
    With Selection
      .ShapeRange.Fill.Visible=False
      .Font.ColorIndex=1
      .ShapeRange.Line.ForeColor.SchemeColor=8
      .ShapeRange.Line.Visible=msoTrue
      .HorizontalAlignment=xlCenter
      .VerticalAlignment=xlCenter
      .Orientation=xlHorizontal
    End With
    ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
    Next
Else
MsgBox "請選擇單個單元格再啟用本程式", vbDefaultButton1+64, "提示"
End If
Application.ScreenUpdating=True
Exit Sub
err:
MsgBox "請選擇單個單元格再啟用本程式", vbDefaultButton1+64, "提示"
End Sub

Sub與系統時間同步()
  [a1]=WorksheetFunction.Text(Now(), "yyyy-mm-dd h:mm:ss")
  Application.OnTime Now+TimeValue("00:00:01"), "與系統時間同步"
End Sub

Sub停止()
  Application.OnTime Now+TimeValue("00:00:01"),"與系統時間同步",,False
End Sub

Sub求范圍之和()
    Dim iMin As Long, iMax As Long, i As Long, temp As Long
    iMin=Application.InputBox("請輸入最小值", "起始值", "0", Type:=1)
    iMax=Application.InputBox("請輸入最大值", "終止值", "100", Type:=1)
    For i=iMin To iMax
    temp=temp+i
    Next
    MsgBox temp
End Sub

Sub利用勾股定理求弦長()
    Dim勾As Integer, 股As Integer
    勾=Application.InputBox("勾", "數據", 3, 10, 10, , , 1)
    股=Application.InputBox("股", "數據", 4, 10, 10, , , 1)
    If勾 <=0 Or股 <=0 Then MsgBox "勾和股必須大于0！": Exit Sub
    MsgBox "弦為:" & WorksheetFunction.Power(勾 ^ 2+股 ^ 2, 0.5)
End Sub

Sub輸入三邊長求三角形面積()
    Dim A, B, C, temp
    A=Application.InputBox("請輸入邊一長度:", "數據", 3, 10, 10, , , 1)
    B=Application.InputBox("請輸入邊二長度:", "數據", 4, 10, 10, , , 1)
    C=Application.InputBox("請輸入邊三長度:", "數據", 5, 10, 10, , , 1)
    temp=(A+B+C) / 2
    If A <=0 Or B <=0 Or C <=0 Then MsgBox "所有邊長都必須大于0": Exit Sub
    If A <=Abs(B-C) Or B <=Abs(A-C) Or C <=Abs(A-B) Then MsgBox
        "兩邊之差不能小于第三邊": Exit Sub
    MsgBox "面積為:" & WorksheetFunction.Power(temp * (temp-A) * (temp-B)
    * (temp-C), 0.5)
End Sub

Sub提示()
MsgBox "會議時間到，請早做準備！", 64, "提示"
End Sub

Private Sub Workbook_Open()
    Application.OnTime #09:00:00 AM#, "提示"
End Sub