ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 3297|回复: 9

[分享] 插入批注

[复制链接]

TA的精华主题

TA的得分主题

发表于 2012-8-19 10:14 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:Range对象
插入批注
插入批注
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


TA的精华主题

TA的得分主题

发表于 2012-9-6 23:07 | 显示全部楼层
谢谢楼主分享,刚需 {:soso_e100:}

TA的精华主题

TA的得分主题

发表于 2012-9-13 12:25 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-9-13 13:27 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-10-13 10:35 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2013-3-14 11:39 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2013-7-3 16:25 | 显示全部楼层
{:soso_e163:} 谢谢分享!

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

TA的精华主题

TA的得分主题

发表于 2013-7-4 01:25 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2013-10-19 17:25 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-1-11 16:05 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-11-18 19:19 , Processed in 0.071008 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表