Sub添加批注()
  Application.OnKey "^{q}", "添加批注" '設(shè)定快捷鍵
  ActiveCell.AddComment             '添加批注
  With ActiveCell.Comment
      .Visible=False              '批注不可見(jiàn)
      .Text Text:=WorksheetFunction.Text(Date, "YYYY-MM-DD") '批注文本
        為日期
      .Shape.TextFrame.AutoSize=True                '批注大小自動(dòng)縮放
  End With
End Sub

Sub批量添加批注()
  For Each Rng In Selection
  If Rng <> "" Then
  Rng.AddComment
    With Rng.Comment
    .Visible=False
    .Text Text:=WorksheetFunction.Text(Date, "YYYY-MM-DD")
    .Shape.TextFrame.AutoSize=True
    End With
  End If
  Next
End Sub

Sub批量刪除批注()
    For Each Rng In Selection
    Rng.ClearComments
    Next
End Sub

Sub批量添加批注()
    For Each Rng In Selection
    If Rng <> "" Then
      Rng.AddComment
      With Rng.Comment
      .Visible=False
      .Text Text:="此員工號(hào)："&WorksheetFunction.VLookup(Rng,Range("I2:J47"),2,0)
      .Shape.TextFrame.AutoSize=True
      End With
    End If
    Next
End Sub

Sub插入圖片標(biāo)注()
    Dim pizhu, pic As String
    Set pizhu=ActiveCell.Comment
    If Not pizhu Is Nothing Then ActiveCell.Comment.Delete '已有批注則刪除批注
    Set pizhu=Nothing                               '釋放變量
    pic=Application.GetOpenFilename(ImgFileformat)  '提取圖片文件
    If pic="False" Then End                        '選擇取消則退出程序
    With ActiveCell
      .AddComment                                  '添加批注
      .Comment.Visible=False                       '批注不可見(jiàn)
      .Comment.Shape.Fill.Transparency=0#             '批注不透明
      .Comment.Shape.Fill.UserPicture pic               '填充圖片
      .Comment.Shape.LockAspectRatio=msoTrue          '設(shè)定圖片透明度
      .Comment.Shape.Height=30#                     '設(shè)定批注高度為30
    End With
    ActiveCell.Select
    '設(shè)置圖片比例，高與寬之比為3∶4
    ActiveCell.Comment.Shape.ScaleWidth 3, msoFalse, msoScaleFromTopLeft
    ActiveCell.Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
End Sub

表達(dá)式.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText,
MultiSelect)

Sub添加個(gè)性化批注()
    Dim mystr As String, mystr2 As String, Comment
    ActiveCell.ClearComments
    mystr=InputBox("輸入批注內(nèi)容", "批注", Application.UserName, 10, 10)
    mystr2=InputBox("輸入批注外型" & Chr(10) & "1為口哨型,2為書卷型,3為箭頭型" _
    & Chr(10) & "4為圓角矩形,5為缺角矩形,6為菱型,7為五角星.", "批注外型", 1, 10, 10)
    If mystr <> "" And mystr2 <> "" Then
      Set Comment=ActiveCell.AddComment
      With Comment
          .Visible=False
          .Text Text:=mystr
          .Visible=True
          .Shape.Select
      End With
      With Selection.ShapeRange
          If mystr2=1 Then .AutoShapeType=
                          msoShapeFlowchartSequential AccessStorage
          If mystr2=2 Then .AutoShapeType=msoShapeFoldedCorner
          If mystr2=3 Then .AutoShapeType=msoShapeRightArrow
          If mystr2=4 Then .AutoShapeType=
                          msoShapeRoundedRectangular Callout
          If mystr2=5 Then .AutoShapeType=msoShapePlaque
          If mystr2=6 Then .AutoShapeType=msoShapeDiamond
          If mystr2=7 Then .AutoShapeType=msoShape5pointStar
      End With
      ActiveCell.Select: Exit Sub
    End If
End Sub

Sub批量修改批注外型()
Dim i As Integer, cell As Range, mystr As String
If TypeName(Selection) <> "Range" Then MsgBox "請(qǐng)選擇單元格!", 64, "
      【友情提示】": Exit Sub  '未選中單元格則退出
On Error GoTo err   '排錯(cuò)，當(dāng)工作表中沒(méi)有批注時(shí)會(huì)出錯(cuò)
mystr=InputBox("輸入批注外型" & Chr(10) & "1為口哨型,2為書卷型,3為箭頭型" _
& Chr(10) & "4為圓角矩形,5為缺角矩形,6為菱型,7為五角星.", "批注外型", 1, 10, 10)
      Application.ScreenUpdating=False
For Each cell In Selection
If Not Application.Intersect(cell, Cells.SpecialCells(xlCellTypeComments))
      Is Nothing Then
With cell.Comment
.Visible=True
.Shape.Select True
End With
With Selection.ShapeRange
If mystr=1 Then .AutoShapeType=msoShapeFlowchartSequentialAccessStorage
If mystr=2 Then .AutoShapeType=msoShapeFoldedCorner
If mystr=3 Then .AutoShapeType=msoShapeRightArrow
If mystr=4 Then .AutoShapeType=msoShapeRoundedRectangularCallout
If mystr=5 Then .AutoShapeType=msoShapePlaque
If mystr=6 Then .AutoShapeType=msoShapeDiamond
If mystr=7 Then .AutoShapeType=msoShape5pointStar
cell.Comment.Visible=False
End With
Else
i=i+1
End If
Next
Application.ScreenUpdating=True
If i=Selection.Count Then MsgBox "選區(qū)中沒(méi)有批注！", 64, "提示"
ActiveCell.Select: Exit Sub
err:
    MsgBox "本工作表中沒(méi)有批注！", 64, "提示"
End Sub

Sub為公式添加標(biāo)注()
    On Error GoTo endd
    Set Rng=Selection.Cells.SpecialCells(xlCellTypeFormulas)
    For Each cell In Rng
      cell.ClearComments
      With cell.AddComment
          .Text Text:=cell.Formula
          With .Shape
              .TextFrame.AutoSize=True
              .Fill.ForeColor.SchemeColor=44
              .AutoShapeType=msoShapePlaque
              If Len(cell.Formula) > 50 And Len(cell.Formula) < 100 Then
                  .Width=300
                  .Height=32
              ElseIf Len(cell.Formula)>=100 And Len(cell.Formula)<150 Then
                  .Width=300
                  .Height=48
              ElseIf Len(cell.Formula)>=150 And Len(cell.Formula)<300 Then
                  .Width=300
                  .Height=95
              ElseIf Len(cell.Formula)>=300 And Len(cell.Formula)<1024 Then
                  .Width=300
                  .Height=150
              End If
              .Visible=False
          End With
      End With
  Next cell
endd:
End Sub