alle Zelländerungen protokollieren

Private Sub Workbook_SheetChange(ByVal Sh As Object, _
                                 ByVal Target As Range)
Dim lngLZ As Long
Dim rngZelle As Range

On Error GoTo Fehler

'Zellwertänderungen aller Tabellen in Tabelle 'wksDoku' eintragen
'Ausnahme: Zelländerung in wksDoku

If Sh.CodeName <> "wksDoku" Then
  'damit DIESE Prozedur durch Eingaben in wksDoku
  'NICHT gestartet wird
  Application.EnableEvents = False

  With wksDoku
    'erste freie Zeile in wksDoku ermitteln
    lngLZ = .Cells(1, 1).End(xlDown).Row + 1

    'wenn wksDoku voll dann alte Inhalte löschen
    If lngLZ > Rows.Count Then
      Call NeuesProtokoll

      'erste freie Zeile in wksDoku ermitteln
      lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    End If

    .Cells(lngLZ, 2) = ActiveSheet.Name
    .Cells(lngLZ, 3) = ActiveSheet.CodeName

    .Cells(lngLZ, 6) = Environ("Username")
    .Cells(lngLZ, 7) = Environ("Computername")
    .Cells(lngLZ, 8) = ThisWorkbook.FullName

    'falls gleichzeitige Eingabe in mehreren Zellen
    For Each rngZelle In Target
      .Cells(lngLZ, 1) = Now
      .Cells(lngLZ, 4) = rngZelle.Address(False, False)

      If rngZelle.Value = "" Then
        .Cells(lngLZ, 5) = "< Inhalt entfernt >"
      Else
        .Cells(lngLZ, 5) = rngZelle.Value
      End If

      lngLZ = lngLZ + 1

      If lngLZ > Rows.Count Then
        Call NeuesProtokoll
        'erste freie Zeile in wksDoku ermitteln
        lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
      End If
    Next

  End With

  Application.EnableEvents = True
End If

Exit Sub

Fehler:
'im Fehlerfall FehlerNr. und Fehlerbeschreibung
'in nächste Zeile von wksDoku eintragen und weitermachen

  'erste freie Zeile in wksDoku ermitteln
  lngLZ = wksDoku.Cells(1, 1).End(xlDown).Row + 1

  'VOR dem schreiben prüfen
  'ob wksDoku voll dann alte Inhalte löschen
  If lngLZ > Rows.Count Then
    Call NeuesProtokoll
    'erste freie Zeile in wksDoku ermitteln
    lngLZ = wksDoku.Cells(Rows.Count, 1).End(xlUp).Row + 1
  End If

  With wksDoku
    .Cells(lngLZ, 1) = Now
    .Cells(lngLZ, 2) = "Err.Number: " & Err.Number
    .Cells(lngLZ, 3) = "Err.Description: " & Err.Description
  End With
  lngLZ = wksDoku.Cells(1, 1).End(xlDown).Row + 1

  'NACH dem schreiben prüfen
  'ob wksDoku voll dann alte Inhalte löschen
  If lngLZ > Rows.Count Then
    Call NeuesProtokoll
    'erste freie Zeile in wksDoku ermitteln
    lngLZ = wksDoku.Cells(Rows.Count, 1).End(xlUp).Row + 1
  End If

  Resume Next
End Sub

Private Sub NeuesProtokoll()
'entfernt alle Protololleinträge in wksDoku
'und schafft damit Platz für neue

With wksDoku
  .Range(.Cells(3, 1), .Cells(Rows.Count, Columns.Count)).Clear

  .Cells(3, 1) = Now
  .Cells(3, 2) = "ALTES PROTOKOLL GELÖSCHT!!!"

  'erste freie Zeile in wksDoku ermitteln
  'lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With

'MsgBox "neues Protokoll"
End Sub