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

-2

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

甘蔗有人帮忙吗？

谢谢！

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

来源

2016-07-29 Ramyaa Seetharaman

** 1）**复习前面的问题：https://stackoverflow.com/search?q=%5Bvba%5D+excel+track+changes ** 2）**写一些代码** 3）**如果您遇到（2） –

@TimWilliams问题，请发回（附代码）谢谢，我正要为他提供建议。 – peterh

我写了我的代码，并且其工作正常，可以跟踪所有更改。以下是代码。但是，如上面问题中提到的那样，如果更改大量单元格，我需要防止它在“LogDetails”表单中创建太多条目。 –

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

来源

2016-07-29 19:25:46

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

回答

相关问题