Excel VBA跟踪对多个单元格的更改

时间：2016-07-29 05:35:47

标签： excel change-tracking

我想要一个宏来跟踪工作表的所有更改，包括多个单元格更改。但是，如果更改了太多的细胞，例如。数据值在单元格v2中复制并粘贴在范围v3：v2000中，然后我希望将更改记录为日志表中的单个条目而不是1998条目。例2。列W中的数据值被清除/删除，应记录为日志表中的单个条目。例3。工作表中插入的新列/行应记录在一个条目中。

凯恩有人帮忙吗？

谢谢！

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 If ActiveSheet.Name <> "LogDetails" And ActiveSheet.Name <> "Introduction" Then
    Application.EnableEvents = False
    vNewValue = Target.Value
    Application.Undo
    vOldValue = Target.Value
    Target.Value = vNewValue
    If Target.Rows.Count = 1 Then
        Call allLogs(Target.Address(0, 0), vOldValue, Target.Value)
        If ActiveSheet.Name = "A4" Or ActiveSheet.Name = "B9" Or ActiveSheet.Name = "M5" Or _
                ActiveSheet.Name = "G8" Or ActiveSheet.Name = "R3" Or ActiveSheet.Name = "K7" Or _
                ActiveSheet.Name = "R7" Or ActiveSheet.Name = "M8" Then
                Call Update_Alpha_Status(Target)
        End If
        If ActiveSheet.Name = "OC Status" Then
            Call Update_Omega_Status(Target)
        End If
    ElseIf Target.Rows.Count > 1 Then
       For rowCount = 1 To Target.Rows.Count
           For colCount = 1 To Target.Columns.Count
               Call allLogs(Target.Cells(rowCount, colCount).Address(0, 0), vOldValue(rowCount, colCount), Target.Cells(rowCount, colCount).Value)
               If ActiveSheet.Name = "A4" Or ActiveSheet.Name = "B9" Or ActiveSheet.Name = "M5" Or _
                ActiveSheet.Name = "G8" Or ActiveSheet.Name = "R3" Or ActiveSheet.Name = "K7" Or _
                ActiveSheet.Name = "R7" Or ActiveSheet.Name = "M8" Then
                   Call Update_Alpha_Status(Target.Range("A" & rowCount & ":U" & rowCount))
               End If
                If ActiveSheet.Name = "OC Status" Then
                    Call Update_Omega_Status(Target.Range("A" & rowCount & ":L" & rowCount))
                End If
            Next
       Next
    End If
     Application.EnableEvents = True
    vOldValue = vbNullString
 End If
End Sub

Public Sub Update_Alpha_Status(ByVal Target As Range)
    Sheets("Alpha Consolidated").Unprotect pWd
    If (Target.Column = 21 Or Target.Column = 22 Or Target.Column = 23) And (Target.Row <> 1) Then
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("D" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Range("B" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Range("O" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Range("U" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Range("V" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = Range("W" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = Range("H" & Target.Row).Value
        Sheets("Alpha Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 7).Value = Date
        Sheets("Alpha Consolidated").Columns("A:H").AutoFit
        ' Remove duplicate rows when updating both status and comments columns
        lastrow = Sheets("Alpha Consolidated").Range("C" & Rows.Count).End(xlUp).Row
        If (Sheets("Alpha Consolidated").Range("C" & lastrow) = Sheets("Alpha Consolidated").Range("C" & lastrow - 1)) Then '_
            If (Sheets("Alpha Consolidated").Range("G" & lastrow) = Sheets("Alpha Consolidated").Range("G" & lastrow - 1)) Then '_
                Sheets("Alpha Consolidated").Range("A" & lastrow - 1).EntireRow.Delete
            End If
        End If
    End If
    Sheets("Alpha Consolidated").Protect Password:=pWd
End Sub
Public Sub Update_Omega_Status(ByVal Target As Range)
    Sheets("Omega Consolidated").Unprotect pWd
    If (Target.Column = 11 Or Target.Column = 12) And (Target.Row <> 1) Then
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Range("A" & Target.Row).Value
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = Range("C" & Target.Row).Value
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = Range("E" & Target.Row).Value
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = Range("K" & Target.Row).Value
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Range("L" & Target.Row).Value
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = Range("J" & Target.Row).Value
        Sheets("Omega Consolidated").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = Date
        Sheets("Omega Consolidated").Columns("A:F").AutoFit
        ' Remove duplicate rows when updating both status and comments columns
        lastrow = Sheets("Omega Consolidated").Range("B" & Rows.Count).End(xlUp).Row
        If Sheets("Omega Consolidated").Range("B" & lastrow) = Sheets("Omega Consolidated").Range("B" & lastrow - 1) Then
            If (Sheets("Alpha Consolidated").Range("G" & lastrow) = Sheets("Alpha Consolidated").Range("G" & lastrow - 1)) Then '_
                Sheets("Alpha Consolidated").Range("A" & lastrow - 1).EntireRow.Delete
            End If
        End If
    End If
    Sheets("Omega Consolidated").Protect Password:=pWd
End Sub
Private Sub allLogs(ByVal addr As Variant, ByVal oldValue As Variant, ByVal newValue As Variant)
    ' Write LogDetails sheet all worksheet changes
    If Sheets("LogDetails").Range("A1") <> "Sheet Name" Then
        Sheets("LogDetails").Range("A1:G1") = Array("Sheet Name", "Cell Changed", "Old Value", "New value", "User", "Date", "Time")
    End If

    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ActiveSheet.Name 'Sheet changed
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 1).Value = addr 'Cell changed
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 2).Value = oldValue 'Old value
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 3).Value = newValue 'New Value
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 4).Value = Environ("username") 'User who changed data
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 5).Value = Date 'Date changed
    Sheets("LogDetails").Range("A" & Rows.Count).End(xlUp).Offset(0, 6).Value = Time 'Time of change
    Sheets("LogDetails").Columns("A:G").AutoFit

End Sub

1 个答案:

答案 0 :(得分：0)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim shtName, arrSheets, c As Range, rw, col, vNewValue, vOldValue

    shtName = Sh.Name 'not always the Active Sheet !

    On Error GoTo haveError

    If shtName <> "LogDetails" And shtName <> "Introduction" Then

        If Target.Columns.Count = Target.EntireRow.Columns.Count Then
            'full row update
            allLogs shtName, Target.Address(0, 0), "<fullRow>", "<fullRow>"

        ElseIf Target.Rows.CountLarge = Target.EntireColumn.Rows.CountLarge Then
            'full column update
            allLogs shtName, Target.Address(0, 0), "<fullCol>", "<fullCol>"

        ElseIf Target.Cells.CountLarge >= 10 Then

            allLogs shtName, Target.Address(0, 0), "<tooMany>", "<tooMany>"

        Else
            Application.EnableEvents = False
            vNewValue = Target.Value
            Application.Undo
            vOldValue = Target.Value
            Target.Value = vNewValue
            For rw = 1 To Target.Rows.Count
                For col = 1 To Target.Columns.Count
                    allLogs shtName, Target.Cells(rw, col).Address(0, 0), _
                            vOldValue(rw, col), vNewValue(rw, col)
                Next col
            Next rw
            Application.EnableEvents = True
        End If

    End If
    Exit Sub

haveError:
    MsgBox Err.Description
    Application.EnableEvents = True

End Sub

Sub allLogs(shtName, addr, oldVal, newVal)
    Debug.Print shtName, addr, oldVal, newVal
End Sub
相关问题
最新问题