[VBA]批注记录修改前内容

Private Sub Worksheet_Change(ByVal Target As Range)
 On Error GoTo err

 Dim Str As String
 Str = "A1:D10,F:H,K:L" '限制添加批注 单元格区域
'Str = "A1:J10" '限制添加批注 单元格区域
    If Target.Rows.Count = Rows.Count Or Target.Column = Columns.Count Then Exit Sub
    If Not Intersect(Target, Range(Str)) Is Nothing Then
        Application.ScreenUpdating = False
        Dim Rag As Range, Tim As String, Arr, Brr
        Tim = Format(Now(), "yyyy年m月d日hh:mm:ss")
        For Each Rag In Intersect(Target, Range(Str))
            If Not Rag.Comment Is Nothing Then
                Arr = Split(Rag.Comment.Text, vbCrLf)
                Brr = Split(Arr(UBound(Arr)), "修改为: ")
                If Trim(Rag.Value) = Trim(Brr(UBound(Brr))) Or (Trim(Rag.Value) = "" And Trim(Brr(UBound(Brr))) = "[空白]") Then Exit Sub
                Rag.Comment.Text Rag.Comment.Text & vbCrLf & Tim & "修改为: " & IIf(Trim(Rag) = "", "[空白]", Rag)
            Else
                If Trim(Rag) <> "" Then Rag.AddComment Tim & "修改为: " & Rag
            End If

            With Rag.Comment.Shape   '美化批注
                ''判断是否已经设置过；如果已经设置过了，就不再设置
                If (.AutoShapeType = msoShapeRoundedRectangle) = False Then
                    .TextFrame.AutoSize = True                   '自适应大小
                    .AutoShapeType = msoShapeRoundedRectangle    '圆角边框
                    .Line.ForeColor.SchemeColor = 53             '边框颜色
                    .Line.Weight = 1                             '边框粗细
                    .TextFrame.Characters.Font.ColorIndex = 5    '字体颜色
                End If
            End With

            Application.ScreenUpdating = True
        Next
    End If
err:
End Sub

转载于:https://www.cnblogs.com/lxu220/p/3362041.html