Excel VBAのトラックが複数のセルに変更される

Question

複数のセルの変更を含むワークシートのすべての変更をマクロがトラッキングするようにしたい。ただし、変更したセルが多すぎると、ex.1。セルv2でコピーされ、範囲v3：v2000に貼り付けられたデータ値。その後、1998年のエントリではなくログシートに1つのエントリとして記録されます。例2。列Wのデータ値は消去/削除され、ログシートに単一のエントリとして記録されます。例3。ワークシートに挿入された新しい列/行は、1つのエントリとして記録されます。

誰かが助けてください？

ありがとうございます！

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 

Answer 1

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