Änderungsprotokoll via Excel VBA

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 der Tabelle Änderungsprotokoll eintragen
'Ausnahme: Zelländerung im Änderungsprotokoll
If Sh.CodeName  "Änderungsprotokoll" Then
'damit DIESE Prozedur durch Eingaben im Änderungsprotokoll
'NICHT gestartet wird
Application.EnableEvents = False
With Änderungsprotokoll
'erste freie Zeile im Änderungsprotokoll ermitteln
lngLZ = .Cells(1, 1).End(xlDown).Row + 1
'wenn Änderungsprotokoll voll dann alte Inhalte löschen
If lngLZ > Rows.Count Then
Call NeuesProtokoll
'erste freie Zeile im Änderungsprotokoll ermitteln
lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
.Cells(lngLZ, 2) = ActiveSheet.Name
.Cells(lngLZ, 3) = ActiveSheet.CodeName
.Cells(lngLZ, 7) = Environ("Username")
.Cells(lngLZ, 8) = Environ("Computername")
.Cells(lngLZ, 9) = 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) = ""
Else
.Cells(lngLZ, 5) = rngZelle.Value
End If
If rngZelle.Value = "" Then
.Cells(lngLZ, 6) = ""
Else
.Cells(lngLZ, 6) = rngZelle.Formula
End If
lngLZ = lngLZ + 1
If lngLZ > Rows.Count Then
Call NeuesProtokoll
'erste freie Zeile im Änderungsprotokoll 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 vom Änderungsprotokoll eintragen und weitermachen
'erste freie Zeile im Änderungsprotokoll ermitteln
lngLZ = Änderungsprotokoll.Cells(1, 1).End(xlDown).Row + 1
'VOR dem schreiben prüfen
'ob Änderungsprotokoll voll dann alte Inhalte löschen
If lngLZ > Rows.Count Then
Call NeuesProtokoll
'erste freie Zeile im Änderungsprotokoll ermitteln
lngLZ = Änderungsprotokoll.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
With Änderungsprotokoll
.Cells(lngLZ, 1) = Now
.Cells(lngLZ, 2) = "Err.Number: " & Err.Number
.Cells(lngLZ, 3) = "Err.Description: " & Err.Description
End With
lngLZ = Änderungsprotokoll.Cells(1, 1).End(xlDown).Row + 1
'NACH dem schreiben prüfen
'ob Änderungsprotokoll voll dann alte Inhalte löschen
If lngLZ > Rows.Count Then
Call NeuesProtokoll
'erste freie Zeile im Änderungsprotokoll ermitteln
lngLZ = Änderungsprotokoll.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
Resume Next
End Sub

Private Sub NeuesProtokoll()
'entfernt alle Protololleinträge im Änderungsprotokoll
'und schafft damit Platz für neue
With Änderungsprotokoll
.Range(.Cells(3, 1), .Cells(Rows.Count, Columns.Count)).Clear
.Cells(3, 1) = Now
.Cells(3, 2) = "ALTES PROTOKOLL GELÖSCHT!!!"
'erste freie Zeile im Änderungsprotokoll ermitteln
'lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With
'MsgBox "neues Protokoll"
End Sub