插入批注

seeyoutime

插入批注
插入批注
poscil = Cells(1, 1).Comment.Text读批注
---------------------------
Function 批注(File2, find名单, r名单1, r名单2, r地点1, r地点2, i1, y4, y1) '写批注
              With Workbooks(File2).Sheets("明细表").Cells(4 + i1, y4 + y1)
                   If .Comment Is Nothing Then '如果不存在批注
                     Else
                     .ClearComments '删除
                   End If
                     If find名单 = r名单1 Then
                        .AddComment Text:=r地点1
                        .Comment.Shape.Width = 30 '宽度
                        .Comment.Shape.Height = 15
                        End If
                     If find名单 = r名单2 Then
                        .AddComment Text:=r地点2
                        .Comment.Shape.Width = 30 '宽度
                        .Comment.Shape.Height = 15
                        End If
              End With
End Function
--------------------------
Function 读批注(月考勤表文件名, i1, 日期) '++批注
              With Workbooks(月考勤表文件名).Sheets("明细表").Cells(4 + i1, 3 + 日期 - 1)
                   If .Comment Is Nothing Then '如果不存在批注
                     Else
                     读批注 = .Comment.Text
                   End If
              End With
End Function
--------------
自动调整批注大小
如何在设定批注的文本框的宽度固定的情况下，使高度自动调整以适应其中所包含的文字？设宽度为150，请看以下的代码：
Sub Comments_AutoSize()
Dim MyComments As Comment
Dim lArea As Long
For Each MyComments In ActiveSheet.Comments
With MyComments
.Shape.TextFrame.AutoSize = True
If .Shape.Width <> 150 Then
lArea = .Shape.Width * .Shape.Height ’ 将批注转成面积
.Shape.Width = 150
.Shape.Height = (lArea / 150)
End If
End With
Next
End Sub
-------------
Sub AutoAddComment()
'错误处理：有错误继续执行下一行
On Error Resume Next
'在当前活动单元格插入批注
ActiveCell.AddComment
'设置批注样式
With ActiveCell.Comment
'文本为当前日期
.Text CStr(Date)
'背景大小自动调整
.Shape.TextFrame.AutoSize = True
End With
End Sub
---------------------------------
Sub ModifyNotes() '批量改批注。
Dim cmt As comment
For Each cmt In ActiveSheet.Comments
With cmt.Shape
With .TextFrame.Characters.Font
.Name = "隶书"
.Size = 10
.ColorIndex = 11
End With
.Fill.ForeColor.SchemeColor = 15
.Line.ForeColor.SchemeColor = 12
'其他的属性输入.号后可以看到。结合帮助文件或录制宏自己视情况添加
End With
Next cmt
End Sub
----------------------------------
Sub kgs()
'我想通过VBA获得word文档中批注所对应的文档内容，
'如附件文档中所表示的。批注1对应的“文档审阅人员”，批注2对应的“出现的批注”等等。
Dim a As Comment
For Each a In ActiveDocument.Comments
      Debug.Print a.Scope.Text
Next
End Sub
0---------------------------------
加批注：
Sub Comment_Add()
    With Range("B5")
        If .Comment Is Nothing Then '如果不存在批注
            .AddComment Text:=.Value
            .Comment.Visible = True
        End If
    End With
End Sub
设置批注字体：
Sub CommentFont()
    Dim Cmt As Comment
    For Each Cmt In ActiveSheet.Comments
        With Cmt.Shape.TextFrame.Characters.Font
            .Bold = msoFalse
            .Size = 9
            .ColorIndex = 3
        End With
    Next
End Sub
--------------------------------------
Sub 我选定的单元格执行这个宏后内容自动到批注去4()
Dim rng As Range
Dim s$
For Each rng In Selection '链接每个单元格里，并强制换行
s = s & rng.Value & Chr(10) '加一个chr(10)，表示强制换行
Next
On Error Resume Next '防止以前有批注发生错误
With Selection.Cells(1, 1).Offset(0, 0) '本单元格的内容
.AddComment '增加批注
.Comment.Text Text:=s '批注里的内容
.Comment.AutoSize = True '自动调整大小
End With
End Sub
-----------------------------
在插入批注的同时直接调整宽度如何？
Sub 我选定的单元格执行这个宏后内容自动到批注去4()
    Dim rng As Range
    Dim s As String, Wid As String, Heig As String
   
    For Each rng In Selection       '链接每个单元格内容
'        s = s & rng.Value & Chr(10) '加一个chr(10)，表示强制换行
        s = s & rng.Value & "。"    '下面要按要求调整宽度，加回车符会影响高度调整，也不好看，这里用“。”代替
    Next
   
    On Error Resume Next        '防止以前有批注发生错误
    With Selection.Cells(1)     '选择区域第一个单元格
        .ClearComments           '删除原来的批注
        .AddComment (s)
        .Comment.Visible = True     '先可见，再自动调整大小
        .Comment.AutoSize = True    '自动调整大小
        .Comment.Shape.TextFrame.AutoSize = True   '你的这一句在字数较少时，可以调整高度
        Wid = .Comment.Shape.Width
        Heig = .Comment.Shape.Height
        If .Comment.Shape.Width > 80 Then
            .Comment.Shape.Width = 80       '宽度80根据要求调整
            .Comment.Shape.Height = Wid / 80 * Heig + Heig
            .Comment.Visible = False
        End If
    End With
   
End Sub
---------------------
Function 指定当前单元格批注大小(a)
  ActiveCell.AddComment Text:="oooo"
  ActiveCell.Comment.Shape.Width = 30 '宽度
  ActiveCell.Comment.Shape.Height = 15
End Function
-------------------
Sub test()'格式
Dim mCom As Comment
For Each mCom In ActiveSheet.Comments
    With mCom.Shape.TextFrame.Characters
        With .Font
                .Bold = msoFalse
                .Size = 9
                .ColorIndex = 3
            End With
        End With
    Next
End Sub
--------------
Sub test()'文件中A单元格中的批注改为9号大小，但是保持批注中第一行的粗体模式
Dim mCom As Comment
'统一为9号字体 ， 是否为粗体，可改Bold属性值为True/False
For Each mCom In ActiveSheet.Comments
    With mCom.Shape.TextFrame.Characters
        With .Font
            '.Bold = msoFalse
            .Size = 9
            ' .ColorIndex = 3
        End With
    End With
Next
End Sub
Sub FindCommText()
Dim mCom As Comment
Dim strCom As String
strCom = "AAA"
For Each mCom In ActiveSheet.Comments
    If InStr(1, mCom.Text, strCom) > 0 Then
        MsgBox "find: " & strCom & vbCrLf & vbNewLine & mCom.Text
    End If
Next
End Sub
--------------------
Sub ReplCommText()‘批注中AAA替换成BBB的语句
Dim Rng As Range
    With ActiveSheet
        On Error Resume Next
        For Each Rng In .UsedRange.SpecialCells(xlCellTypeComments)
           Rng.Comment.Text Replace(Rng.Comment.Text(), "AAA", "BBB")
        Next Rng
    End With
End Sub

element519

谢谢楼主分享，刚需 {:soso_e100:}

molihim

      顶一下

tianyk

好 做个记号

joyark

謝謝提供學習

wuwei-wuwei

谢谢楼主分享

mustang88

{:soso_e163:} 谢谢分享！

同时请教一下：
能否读取批注及其文字格式，并进行多个带格式批注内容的合并，以便复制到剪切板中供WORD等软件使用？

bluexuemei

关于批注的好贴，收藏！

蓝星2012

顶顶顶顶顶

蔡明江

收藏了 谢谢不错的分享！