设置批注的属性---位置、边框、高度、颜色等

nbchn

近期工作中经常使用到批注，可是批注的位置却不是很理想，如果批注很多要改动就很麻烦，就想用VBA实现批注位置自动放到指定位置，在论坛中找了几天，在其他代码的基础上必了一下，为了方便像我这样的新人使用，特注释了放上来大家公享。本贴所有代码都是在论坛里找的，已忘记出处，敬请谅解。

Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' 鼠标单击事件
    Application.ScreenUpdating = False   '关闭屏幕刷新
    On Error Resume Next                  '忽略错误
    Application.EnableEvents = False '先禁止触发事件
    Application.Calculation = xlCalculationManual    '手动重算

    Dim lngRow As Long, LngColumn   As Long, xx As Range ,  Lk  As Range , lArea As Long  ‘定义类型

    LngColumn = Target.Column      '获取当前单元格的列号
    lngRow = Target.Row                  '获取当前单元格 的行号

        For Each xx In Cells(lngRow, LngColumn) '只修改当前选中单元格的批注属性   'ActiveSheet.Cells.SpecialCells(xlCellTypeComments)   ’修改所有批注属性
                xx.Comment.Visible = False               '   / True '如果希望备注显示，留True，不显示，留False                Lk = xx.ColumnWidth                      '设置Lk等于单元格列宽
               With xx.Comment.Shape
                        .Left = xx.Offset(0, 3).Left        '设置批注左右位置，Offset(0, 3) 中后一个数是正数时显示在右边，负数时显示在左边，3表示批注显示在本单元格右边第3列，
                        .Top = xx.Offset(-1, 0).Top      '设置批注上下位置， Offset(0, 3) 中后一个数是正数时显示在下边，负数时显示在上边，3表示批注显示在本单元格右边第3行，
                        .TextFrame.AutoSize = True      '自动适应内容                             
                        lArea = .Width * .Height           
                        .Width = Lk * 6.1                      ‘定义批注宽度等于单元格列宽
                        .Height= (lArea / .Width * 6.1) * 0.3                               ' ‘定义批注高度
                        .AutoShapeType = msoShapeRoundedRectangle       '圆角边框
                        .Line.ForeColor.SchemeColor = 53                              '边框颜色
                        .Line.Weight = 1                                                         '边框粗细
                        .TextFrame.Characters.Font.ColorIndex = 5               '字体颜色
                 End With
          Next xx


    Application.Calculation = xlCalculationAutomatic    '自动重算
    Application.EnableEvents = True                      '恢复触发事件
    On Error GoTo 0                                      '恢复正常的错误提示
    Application.ScreenUpdating = True                    '开启屏幕刷新                                 
End Sub

可怕的舒克

非常有用 谢谢分享

bzmbq

很好，辛苦了，谢谢。

newlove

收了！支持一下！

gwjkkkkk

谢谢楼主分享。。。

xvjiex

感谢楼主分享设置批注的属性

ggmmlol

冷门知识急用时不好找资料，值得收藏，鲜花奉上，予人玫瑰，手有余香，感谢分享。

lingdo2001

蓦然回首那贴正在灯火阑珊处