Ich nutze folgenden Code um alle Zellveränderungen zu 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 <> "wksAdmin" Then
'damit DIESE Prozedur durch Eingaben in wksAdmin
'NICHT gestartet wird
Application.EnableEvents = False
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
Application.EnableEvents = True
'zweites End If für wksAdmin-If Funktion
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
Bei uns auf der Arbeit werden ausgefallene Arbeiten in Excel Dokumentiert (gestrichen) „STRG + 5“.
Leider wird dies nicht protokolliert.
Gibt es eine Möglichkeit dieses anders zu lösen?
Vielleicht mit der gesamten Formatierung protokollieren?
PasteSpecial Paste:=xlPaste
Ich zermalme mir schon mehrere Tage den Kopf deswegen.
Vielen Dank vorab