VBA在注釋框中保留更改

Question

現在，我正在使用此功能在注釋中保留單元格中數據的最后更改：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    val_before = Target.Value

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Count > 1 Then
        MsgBox Target.Count & " cells were changed!"
        Exit Sub
    End If

    If Target.Comment Is Nothing Then
        Target.AddComment
        existingcomment = ""
    Else
        existingcomment = Target.Comment.Text & vbLf & vbLf
    End If

    Target.Comment.Text Text:=Format(Now(), "DD.MM.YYYY hh:mm") & ":" & vbLf & Environ("UserName") & _
        " changed " & val_before & Target.Address & " from:" & vbLf & """" & val_before & _
        """" & vbLf & "to:" & vbLf & """" & Target.Value & """"

End Sub

原始答案在這里： VBA最后更改方法

但是我正在嘗試更改它，以在注釋框中最多保留5個歷史記錄更改，並且在進行新更改時，刪除最舊的更改。 我當時正在考慮執行以下操作：

'計數：（從時間開始，雙點），當大於5時，比較更改的日期和時間，刪除最早的一個並記錄新的（第6個）。

有誰有更好的主意嗎？ 我是VBA和編程的新手。

Answer 1

首先，這是一個很酷的主意:)

理想情況下，您將擁有一個數組變量，其最大值為 5條評論，您將使用該數組從頭開始填充評論。 但是，由於您的目標是支持所有單元的通用解決方案，因此我可以看到這將變得有些復雜。 我假設您可能還希望在關閉工作表后保留歷史記錄。

對於這樣的事情，數據庫當然也是一個很好的應用程序，但是我猜測建立數據庫連接對於您的目的而言將是太多的工作。

話雖這么說...您建議的方法並不是那么漂亮或可靠，但是我喜歡您的目的。 但是，需要進行以下調整：

• 不要計算冒號（“雙點”，:)。 每個注解中肯定會有不止一個。 相反，我可能會在每個評論的末尾添加分隔線或其他內容，例如

   Target.Comment.Text = Target.Comment.Text & vbCrLf & "--------------" & vbCrLf 

  或者您可以只連續計算兩個vbLf（您當前擁有的）

• 除了計算之外，我可能會像這樣拆分注釋：

   comments = Split(Target.Comment.Text, vbLf & vbLf) 

  這樣就為您提供了所有評論的數組（評論），然后您可以像這樣循環遍歷：

   For i = 0 to UBound(comments) ' do stuff with comments(i) here Next 

希望有幫助，如果不清楚或您還有其他問題，請告訴我。

Answer 2

這就是我要這樣做的方式-我假設工作表事件足夠瑣碎，因此我正在制作一個子例程，該例程從單元格中獲取值並將其添加到注釋中，因為這是重要的部分。

允許的評論數是一個常量，定義為NUMBER_OF_COMMENTS 。 分隔符也是一個常量， DELIM = " >> " 。

輸入范圍內的值后，子程序將其接收並通過循環將其添加到注釋中。 我在單元格中輸入文本Test 00N 。 看起來比解釋更好：

這是注釋的樣子，在單元格中插入100個值之后，僅保留注釋中的最后5個：

如您所見，僅采用最后5個值。 如果將NUMBER_OF_COMMENTS更改為12，我們將得到：

：

代碼如下所示：

Public Sub TestMeCaller()        
    Dim cnt As Long        
    For cnt = 1 To 100
        TestMe cnt
    Next cnt        
End Sub

-

Public Sub TestMe(counter As Long)

    Dim rangeWithComment        As Range
    Dim commentText             As String
    Dim commentArray            As Variant
    Dim cnt                     As Long

    Const DELIM = " >> "
    Const NUMBER_OF_COMMENTS = 12

    Set rangeWithComment = Cells(2, 2)
    rangeWithComment = "TEST 00" & counter
    commentText = DELIM & rangeWithComment
    rangeWithComment.ClearContents

    If rangeWithComment.Comment Is Nothing Then
        rangeWithComment.AddComment
        rangeWithComment.Comment.Text (commentText)
        Exit Sub
    Else
        commentArray = Split(rangeWithComment.Comment.Text, DELIM)
    End If

    For cnt = LBound(commentArray) + 1 To UBound(commentArray)        
        If cnt >= NUMBER_OF_COMMENTS Then Exit For
        commentText = commentText & _ 
                      IIf(cnt = 1, vbCrLf, vbNullString) &  DELIM & commentArray(cnt)
    Next cnt

    rangeWithComment.Comment.Text (commentText)

End Sub

如果您開始在單元格中輸入“ >>”之類的代碼，則該代碼將被破壞，但這可能是您可以接受的。

Answer 3

所以，這是我的工作版本：

Private Sub Worksheet_Change(ByVal Target As Range)

   If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
   If Target.Row <= 2 Then GoTo EndeSub
   If Not Intersect(Range("C:JA"), Target) Is Nothing Then
     On Error GoTo EndeSub
     Application.EnableEvents = False
     Range("B" & Target.Row) = Now
   End If

    Application.Volatile
    Dim CommentBox As Object
    Set CommentBox = Range("B" & Target.Row).Comment
    Dim CommentString As String

    If Not CommentBox Is Nothing Then
        If CommentBox.Text <> "" Then
            CommentString = CommentBox.Text
            Range("B" & Target.Row).Comment.Delete
        End If
    Else
        CommentString = ""
    End If

    Dim CommentTemp As String
    CommentTemp = CommentString
    Dim LastDoubleDotPosition As Integer
    LastDoubleDotPosition = 0
    Dim LongestName As Integer
    LongestName = 0

    If InStr(CommentTemp, ":") > 0 Then StillTwoDoubleDots = True

    Do While InStr(CommentTemp, ":") > 0


        If InStr(CommentTemp, ":") > LongestName Then LongestName = InStr(CommentTemp, ":")
        CommentTemp = Right(CommentTemp, Len(CommentTemp) - InStr(CommentTemp, ":"))

    Loop

    count = CountChr(CommentString, ":")

    If count >= 5 Then

        LastDoubleDotPosition = Len(CommentString) - Len(CommentTemp) - 1
        CommentString = Left(CommentString, LastDoubleDotPosition - 13)

    End If

    'insert comment
    Dim FinalComment As String
    FinalComment = Format(Now(), "DD.MM.YYYY hh:mm") & " " & "by" & " " & Application.UserName & vbCrLf & CommentString 'newComment and the oldcomment
    Range("B" & Target.Row).AddComment FinalComment

    Set CommentBox = Range("B" & Target.Row).Comment

    LongestName = LongestName * 5
    If LongestName < 150 Then LongestName = 150

    With CommentBox
        .Shape.Height = 60
        .Shape.Width = LongestName
    End With


EndeSub:
    Application.EnableEvents = True

End Sub

'counter
Public Function CountChr(Expression As String, Character As String) As Long

    Dim Result As Long
    Dim Parts() As String
    Parts = Split(Expression, Character)
    Result = UBound(Parts, 1)
    If (Result = -1) Then
    Result = 0
    End If
    CountChr = Result

End Function

要求已更改，我只在注釋框中保留更改的時間和日期以及用戶名。