2016-07-29 12 views
-2

Ich möchte ein Makro, um alle Änderungen an Arbeitsblättern zu verfolgen, einschließlich mehrere Zellenänderungen. Wenn jedoch zu viele Zellen geändert werden, z. Datenwert kopiert in Zelle v2 und eingefügt in Bereich v3: v2000, dann möchte ich die Änderung als einen einzigen Eintrag im Protokollblatt anstelle von 1998 Einträge aufgezeichnet werden. ex.2. Datenwerte in Spalte W werden gelöscht/gelöscht, sollten als Einzeleintrag im Protokollblatt aufgezeichnet werden. ex.3. Eine neue Spalte/Zeile, die in das Arbeitsblatt eingefügt wird, sollte mit einem Eintrag versehen werden.Excel VBA verfolgen Änderungen an mehreren Zellen

Cane jemand Hilfe bitte?

Danke!

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

** 1) ** vorherigen Fragen Bewertung: https://stackoverflow.com/search?q=%5Bvba%5D+excel+track+changes ** 2) ** einige Code schreiben ** 3) ** Poste zurück (mit Code) wenn du Probleme mit (2) –

+0

@TimWilliams hast. Danke, ich war dabei ihn zu beraten. – peterh

+0

Ich habe meinen Code geschrieben und funktioniert gut, um alle Änderungen zu verfolgen. Unten ist der Code. Ich muss jedoch verhindern, dass es zu viele Einträge im Blatt "LogDetails" erzeugt, wenn eine große Anzahl von Zellen wie in der obigen Frage erwähnt geändert wird. –

Antwort

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 
Verwandte Themen