Sub添加批注()
  Application.OnKey "^{q}", "添加批注" '设定快捷键
  ActiveCell.AddComment             '添加批注
  With ActiveCell.Comment
      .Visible=False              '批注不可见
      .Text Text:=WorksheetFunction.Text(Date, "YYYY-MM-DD") '批注文本
        为日期
      .Shape.TextFrame.AutoSize=True                '批注大小自动缩放
  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:="此员工号："&WorksheetFunction.VLookup(Rng,Range("I2:J47"),2,0)
      .Shape.TextFrame.AutoSize=True
      End With
    End If
    Next
End Sub

Sub插入图片标注()
    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                       '批注不可见
      .Comment.Shape.Fill.Transparency=0#             '批注不透明
      .Comment.Shape.Fill.UserPicture pic               '填充图片
      .Comment.Shape.LockAspectRatio=msoTrue          '设定图片透明度
      .Comment.Shape.Height=30#                     '设定批注高度为30
    End With
    ActiveCell.Select
    '设置图片比例，高与宽之比为3∶4
    ActiveCell.Comment.Shape.ScaleWidth 3, msoFalse, msoScaleFromTopLeft
    ActiveCell.Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
End Sub

表达式.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText,
MultiSelect)

Sub添加个性化批注()
    Dim mystr As String, mystr2 As String, Comment
    ActiveCell.ClearComments
    mystr=InputBox("输入批注内容", "批注", 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 "请选择单元格!", 64, "
      【友情提示】": Exit Sub  '未选中单元格则退出
On Error GoTo err   '排错，当工作表中没有批注时会出错
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 "选区中没有批注！", 64, "提示"
ActiveCell.Select: Exit Sub
err:
    MsgBox "本工作表中没有批注！", 64, "提示"
End Sub

Sub为公式添加标注()
    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