automatisches kopieren

Private Sub Worksheet_Change(ByVal Target As Range)
Dim RNG As Range, Zeile As Long, SpName As Integer, SpSuch As Integer, SpalteNeu As Integer
Dim NName As String, Tb1 As Worksheet, Tb2 As Worksheet
Set Tb1 = Sheets("dbPersonal")
Set Tb2 = Sheets("Gehaltsentwicklung")
SpName = 8 'Namen in Spalte H
SpSuch = 1 'Namen stehen in Spalte A
Set RNG = Tb1.Range("AX2:AX1000")
If Not Intersect(RNG, Target) Is Nothing Then
If Target  "" Then
NName = Tb1.Cells(Target.Row, SpName)
If NName  "" And WorksheetFunction.CountIf(Tb2.Columns(SpSuch), NName) > 0 Then
'Name gefunden in Zeile
Zeile = WorksheetFunction.Match(NName, Tb2.Columns(SpSuch), 0)
'letzte Spalte einer Zeile
SpalteNeu = Tb2.Cells(Zeile, Tb2.Columns.Count).End(xlToLeft).Column
Tb2.Cells(Zeile, SpalteNeu + 1) = Target
Tb2.Cells(Zeile, SpalteNeu + 2) = Format(Target.Offset(0, 2), "DD.MM.YYYY")
Else
MsgBox "Name unbekannt"
End If
End If
End If
End Sub