[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