Änderungen Protokollieren

Question

Hallo,

ich habe mal wieder ein Problemchen.
Ich suche ein VBA-Code, welcher Änderungen dokumentiert...wie
folgt:

Tabelle 1 - D22-D500 Überwachen und bei Änderung fortlaufen den
Inhalt (bis zum Zeichen @) der geänderten Zelle und den User in
Tabelle2 übertragen (wenn in Zelle A der Wert "Completed" gesetzt
wurde)

Finde ja folgenden Code schon ganz super, aber leider fehlen mir
die fertigkeiten :-(
Private Sub Worksheet_Change(ByVal Target As Range)
Const tCheckRange = "D22:D100" ' Dieser Bereich wird auf
Änderungen geprüft
Const lColRevDate = 10 ' In diese Spalte soll protokolliert werden:
Datum
Const lColRevName = 11 ' In diese Spalte soll protokolliert werden:
User
Const lColRevAddr = 12 ' Ab dieser Spalte soll protokolliert werden:
Zelle
Dim rC As Range
If Intersect(Target, Me.Range(tCheckRange)) Is Nothing Then Exit
Sub
Application.EnableEvents = False
For Each rC In Target.Cells
Me.Cells(rC.Row, lColRevDate) = Now()
Me.Cells(rC.Row, lColRevName) = Environ("Username")
Me.Cells(rC.Row, lColRevAddr + rC.Column - Target.Column) =
rC.Address(0, 0)
Next
Application.EnableEvents = True
End Sub

Hoffe jemand hat nen Einfall ;-)

LG Sweni

Answer 1

axxo, kleiner Fehler D22-D500 wird nicht geändert sondern nur A22-
A500, aber der dazugehörige D soll kopiert werden

LG Sweni

Answer 2

Hallo Sweni,
vielleicht hilft dir der Code weiter.
Code in Tabelle1 einfügen.

Tab2 A1 B1 C1 D1 E1 F1
Datum Name Spalte A Zeile: neu alt Alter Wert


Gruß
fedjo

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strAdresse As String
strAdresse = Target.Address(False, False)
If Target.Column = 1 And Cells(Target.Row, Target.Column) <> "" Then
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Sheets("Tabelle2").Range("F2") 'alter Wert einfügen
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = Now()
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = Application.UserName
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(0, 2) = strAdresse
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(0, 3) = Target.Value
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Target, Range("A:A")) Is Nothing Then
Sheets("Tabelle2").Range("F2") = Selection ' alter Wert übernehmen
End If
End Sub

Answer 3

Hab das jetzt so hinbekommen, dass Änderungen in ein neues Sheet
protokolliert werden und gleich folgende Werte dabei gezogen werden.

Sheet2: A= User B=Kundennummer C=Timestamp

jetzt habe ich vor, die Kundennummer (spalte i) in Sheet 1 mit dem
Sheet2 zu vergleichen und in Spalte G den entsprechenden User
hinzukopieren, so dass der Mitarbeiter immer mit dem selben Kunden
zu tun hat sobald eine Anfrage des Kunden kommt.

hoffe jemand hat da noch ne Idee?