Ich habe die Funktion mal erweitert und meine eigene Variante gebaut:
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'On Error GoTo restoreSettings
Application.EnableEvents = False
Dim VN, VO, ProtRow$(0, 8)
Dim iRow As Integer, newTarget As Object
Dim tSh As Worksheet
Dim TAdd$, TRAdd$, TRsAdd$, TParent$
Dim V1, V2, V3
'set
Set tSh = Worksheets("Protokollierung")
Set newTarget = ActiveCell
With Target
TAdd = .Address(False, False)
TRAdd = Target(1, 1).EntireRow.Address(False, False)
TRsAdd = .EntireRow.Address(False, False)
TParent = .Parent.Name
If TAdd = TRAdd Then
VN = "Zeile geändert"
ElseIf TAdd = TRsAdd Then
VN = "Mehere Zeilen geändert"
ElseIf .Rows.Count > 1 Or .Columns.Count > 1 Then
VN = "Bereich geändert"
Else
VN = .Value
Application.Undo
If .Rows.Count < 2 And .Columns.Count < 2 Then
VO = .Value
.Value = VN 'Wert wiederherstellen
End If
newTarget.Select 'Selektion wiederherstellen
End If
End With
'Protokoll erstellen
iRow = tSh.Cells(Rows.Count, 1).End(xlUp).Row + 1
ProtRow(0, 0) = iRow - 1 'Index
ProtRow(0, 1) = Application.UserName
ProtRow(0, 2) = Now() 'Änderrungsdatum
ProtRow(0, 3) = TParent 'Sheet name
ProtRow(0, 4) = TAdd 'Zelladdresse
ProtRow(0, 5) = VO 'Alter Wert
ProtRow(0, 6) = ">"
ProtRow(0, 7) = VN 'Neuer Wert
ProtRow(0, 8) = Target(1, 2) 'Datum
'Daten übertragen
With tSh
.Range(.Cells(iRow, 1), .Cells(iRow, 1 + UBound(ProtRow, 2))).Value = ProtRow
.Columns.AutoFit
End With
restoreSettings:
Application.EnableEvents = True
End Sub
Error-Handler sollte die Funktion nicht mehr brauchen, falls es doch zu fehlern kommt, kannst du den ja wieder aktivieren. Die Funktion musst du in das Modul "Diese Arbeitsmappe" packen.
|