Eigentlich unlösbar,... und trotzdem...
10.02.2009 10:40:00
Ramses
Hallo
hier mal eine Variante.
Ist zwar komplex, sollte aber tun.
Die Protokollierung wird nur begonnen, wenn in der geänderten Zelle bereits ein Wert steht.
Ist die Zelle leer und es erfolgt ein Eintrag, dann erfolgt keine Protokollierung.
Wird das Makro einmal unterbrochen, dann funktioniert nix mehr .-)
Das gehört in ein Modul deiner Mappe
Option Explicit
Public oldRngAdd As Range
Public oldContent As Variant
Public wksProtBol As Boolean
Das gehört in das Klassenmodul der Tabelle wo die Protokollierung funktionieren soll
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim protSheet As Worksheet, wksProtName As String
Dim chkOldRng As Range, lastRow As Long
'Prüfen ob Protocolldatei vorhanden
wksProtName = "chkProtocol"
If wksProtBol <> True Then
For Each wks In ThisWorkbook.Worksheets
If wks.Name = wksProtName Then
wksProtBol = True
Exit For
End If
Next
If wksProtBol = False Then
Application.ScreenUpdating = False
Worksheets.Add
With ActiveSheet
.Name = wksProtName
.Cells(1, 1) = "Adresse"
.Cells(1, 2) = "Alter Wert"
.Cells(1, 3) = "Alter Farbwert"
.Cells(1, 4) = "Geändert durch User"
.Visible = xlVeryHidden
End With
Application.ScreenUpdating = True
End If
End If
Set protSheet = Worksheets(wksProtName)
If Not oldRngAdd Is Nothing Then
'Es ist ein Protkolleintrag vorhanden
On Error Resume Next
With protSheet
'Suchen ob bereits ein Eintrag im Protokoll vorhanden ist
Debug.Print Target.Address
Set chkOldRng = .Columns(1).Find(Target.Address)
Debug.Print chkOldRng.Offset(0, 1)
Debug.Print chkOldRng.Row
If Not chkOldRng Is Nothing Then
'Keine Änderung
If Target.Value = oldContent Then Exit Sub
If chkOldRng.Offset(0, 1) = Target.Value Then
'Eintrag vorhanden und gleicher Wert wie in Target
'Farbe zurücksetzen und Protokolleintrag löschen
Target.Interior.ColorIndex = .Cells(chkOldRng.Row, 3)
protSheet.Rows(chkOldRng.Row).EntireRow.Delete
Else
'Wert wurde geändert
'zelle markieren mit Roter Farbe
Target.Interior.ColorIndex = 3
End If
Else
With protSheet
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lastRow, 1) = Target.Address
.Cells(lastRow, 2) = Target.Value
.Cells(lastRow, 3) = Target.Interior.ColorIndex
.Cells(lastRow, 4) = Environ("Username")
End With
Target.Interior.ColorIndex = 3
End If
End With
Else
'Es muss ein neuer Protokolleintrag erstellt werden
'aber nur wenn ein wert in der Zelle steht
If IsEmpty(Target) Then Exit Sub
With protSheet
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(lastRow, 1) = Target.Address
.Cells(lastRow, 2) = Target.Value
.Cells(lastRow, 3) = Target.Interior.ColorIndex
.Cells(lastRow, 4) = Environ("Username")
End With
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'bestehende Werte speichern
If Not IsEmpty(Target) Then
'Variable enthält Werte
'Im Change Ereignis wird gespeichert/protokolliert
Set oldRngAdd = Target
oldContent = Target.Value
Else
'Variable = Nothing
'Im change Ereignis wird nichts gespeichert/protokolliert
Set oldRngAdd = Nothing
End If
End Sub
Viel Sapss beim probieren.
Am besten in einer leeren Mappe mit einer leeren Tabelle beginnen
Gruss Rainer