Код VBA, чтобы добавить комментарий только ПОСЛЕ изменения начального значения ячейки?

Question

У меня есть форма ввода данных, которая позволяет пользователям вводить данные в определенные ячейки.То, что я хочу, это способ отслеживать изменения значений ячеек.Когда данные вводятся изначально через форму ввода, я не хочу, чтобы эта информация отслеживалась.Однако, если пользователь пытается изменить / отредактировать введенные данные, я хочу добавить комментарий, чтобы показать начальное значение и исправленное значение.

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim singlecell As Range

    If Target.Cells.CountLarge > 1000 Then Exit Sub

    For Each singlecell In Target

        If singlecell.Comment Is Nothing Then
            singlecell.AddComment Now & " - " & singlecell.Value & " - " & Environ("UserName")
        Else
            singlecell.Comment.Text _
                vbNewLine & Now & " - " & singlecell.Value & " - " & Environ("UserName") _
                , Len(singlecell.Comment.Text) + 1 _
                , False

        End If

        singlecell.Comment.Shape.TextFrame.AutoSize = True

    Next singlecell

End Sub

Код, который я пробовал, добавляет комментарий при отправке информации из формы ввода.Однако мне пока не нужно, чтобы комментарий показывался, я хочу, чтобы пользователь изменял начальное значение ячейки.

Answer 1

Вы можете использовать массив helper для временного хранения всех текущих комментариев к ячейке и получения конфиденциального текста из последнего записанного комментария для сравнения с текущим содержимым ячейки

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim singleCell As Range

    Dim commentsArray As Variant 'array to hold all singleCell comments
    Dim oldText As String ' string to hold last comment sensitive content

    If Target.Cells.CountLarge > 1000 Then Exit Sub


    For Each singleCell In Target

        If singleCell.Comment Is Nothing Then
            singleCell.AddComment Now & " - " & singleCell.Value & " - " & Environ("UserName")
        Else

            commentsArray = Split(singleCell.Comment.Text, vbNewLine) ' fill the array with current singleCell comments
            oldText = CStr(Split(commentsArray(UBound(commentsArray)), " - ")(1)) ' extract last recorded comment sensitive text

            'update comment if current cell value differs from last recorded comment sensitive text
            If oldText <> CStr(singleCell.Value2) Then _
                singleCell.Comment.Text _
                vbNewLine & Now & " - " & singleCell.Value & " - " & Environ("UserName") _
                , Len(singleCell.Comment.Text) + 1 _
                , False

        End If

        singleCell.Comment.Shape.TextFrame.AutoSize = True

    Next
End Sub

Answer 2

Скопируйте и создайте ту же таблицу на том же листе, чтобы она была скрыта,

Sub CopyCurrentTable()

    Application.ScreenUpdating = False
    With shtMapping
        .Range("E4:G1000").ClearContents 'which value to which value you are copying
        .Range("B4:D" & GetLastRow(shtMapping, "B", 4)).Copy ' starting postion
        .Range("E4").PasteSpecial xlPasteAll 
        Application.CutCopyMode = False
    End With

End Sub
Sub LogAuditTrail()

    Dim colOld As Collection
    Dim colNew As Collection
    Dim objNew As ClsMapping
    Dim objOld As ClsMapping
    Set colOld = getMappingData("E")
    Set colNew = getMappingData("B")
    Dim sTS As String

    sTS = Format(Now, "dd-mmm-yyy hh:mm:ss")

    For Each objNew In colNew
        'Detect Items Changed
        If ItemIsInCollection(colOld, objNew.getKey) Then
            Set objOld = colOld(objNew.getKey)
            If objNew.isDifferent(objOld) Then
                Call PlotToAudit(objNew, objOld, sTS, "Change")
            End If
        Else
            'Detect Items Added
            Set objOld = New ClsMapping
            Call PlotToAudit(objNew, objOld, sTS, "New")
        End If
    Next objNew

    'Detect Items removed
    For Each objOld In colOld
        If Not ItemIsInCollection(colNew, objOld.getKey) Then
            Set objNew = New ClsMapping
            Call PlotToAudit(objNew, objOld, sTS, "Removed")
        End If
    Next objOld

End Sub

Sub PlotToAudit(obj1 As ClsMapping, obj2 As ClsMapping, sTS As String, sType As String)

    Dim lRow As Long
    lRow = shtAudit.Range("B1048576").End(xlUp).Row

    If lRow = 3 Then
        lRow = 5
    ElseIf lRow = 1048576 Then
        MsgBox "Audit sheet is full. Contact Support." & vbNewLine & "No audit trail will be saved", vbCritical, "ERROR"
        Exit Sub
    Else
        lRow = lRow + 1
    End If

    With shtAudit
        .Unprotect g_sPassword
        .Range("B" & lRow).value = Application.UserName & "(" & Environ("USERNAME") & ")"
        .Range("C" & lRow).value = sTS
        .Range("D" & lRow).value = sType

        Select Case sType
            Case "Removed"
                .Range("E" & lRow).value = ""
                .Range("F" & lRow).value = ""
                .Range("G" & lRow).value = ""
                .Range("H" & lRow).value = obj2.FundCode
                .Range("I" & lRow).value = obj2.Subs
                .Range("J" & lRow).value = obj2.Reds
            Case "New"
                .Range("E" & lRow).value = obj1.FundCode
                .Range("F" & lRow).value = obj1.Subs
                .Range("G" & lRow).value = obj1.Reds
                .Range("H" & lRow).value = ""
                .Range("I" & lRow).value = ""
                .Range("J" & lRow).value = ""
            Case "Change"
                .Range("E" & lRow).value = obj1.FundCode
                .Range("F" & lRow).value = obj1.Subs
                .Range("G" & lRow).value = obj1.Reds
                .Range("H" & lRow).value = obj2.FundCode
                .Range("I" & lRow).value = obj2.Subs
                .Range("J" & lRow).value = obj2.Reds
        End Select
        With .Range("B" & lRow & ":J" & lRow)
            .Interior.Color = vbWhite
            .Borders.LineStyle = xlContinuou
        End With
        .Protect g_sPassword
    End With

End Sub