das liegt daran, dass aus der selektierten Zelle die Zeilennummer ausgewertet wird. Im Klartext:
Worksheet_Change feuert bei jeder Änderung im Tabellenblatt unter der Voraussetzung, dass in einer Zelle etwas stattfand (Änderung/Selektierung).
Man könnte in einer Schleife nach jedem Eintrag alles abklappern und die Änderungen zurückschreiben. Dann wäre es sinnvoll dies via Array zu erledigen. Recourcenfreundlich ist das aber nicht (deshalb mit Array), da mit jeder Änderung die Schleife durchlaufen wird.
Code:
Sub Datum1()
Dim i&, j&, k&, lz&, Spalte1 As Range, Spalte2 As Range, arrDatum()
'Geburts Datum
With Tabelle1
Set Spalte1 = .Rows(6).Find("Geburt-Datum")
If Not Spalte1 Is Nothing Then k = Spalte1.Column
Set Spalte2 = .Rows(6).Find("Geburt.-.Datum")
If Not Spalte2 Is Nothing Then j = Spalte2.Column
lz = .Cells(Rows.Count, k).End(xlUp).Row
ReDim arrDatum(1 To lz - 6)
For i = 1 To lz - 6
If Len(.Cells(i + 6, k)) = 4 Then arrDatum(i) = .Cells(i + 6, k)
If Len(.Cells(i + 6, k)) = 7 Then
If Left(.Cells(i + 6, k), 2) = "01" Then
arrDatum(i) = "JAN " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6 + 6, k), 2) = "02" Then
arrDatum(i) = "FEB " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "03" Then
arrDatum(i) = "MRZ " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "04" Then
arrDatum(i) = "APR " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "05" Then
arrDatum(i) = "MAI " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "06" Then
arrDatum(i) = "JUN " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "07" Then
arrDatum(i) = "JUL " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "08" Then
arrDatum(i) = "AUG " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "09" Then
arrDatum(i) = "SEPT " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "10" Then
arrDatum(i) = "OKT " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "11" Then
arrDatum(i) = "NOV " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 2) = "12" Then
arrDatum(i) = "DEZ " & Right(.Cells(i + 6, k), 4)
End If
Else
If Mid(.Cells(i + 6, k), 4, 2) = "01" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " JAN " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "02" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " FEB " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "03" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " MRZ " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "04" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " APR " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "05" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " MAI " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "06" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " JUN " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "07" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " JUL " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "08" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " AUG " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "09" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " SEPT " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "10" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " OKT " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "11" Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " NOV " & Right(.Cells(i + 6, k), 4)
End If
If Mid(.Cells(i + 6, k), 4, 2) = "12 " Then
arrDatum(i) = Left(.Cells(i + 6, k), 2) & " DEZ " & Right(.Cells(i + 6, k), 4)
End If
End If
' .............Der folgende Eintrag ändert die Tage 01 bis 09 nach 1 bis 9 .........
If Left(.Cells(i + 6, j), 1) = "0" Then arrDatum(i) = Mid(.Cells(i + 6, j), 2, 20)
If Left(.Cells(i + 6, k), 4) = "vor " Then
arrDatum(i) = "BEF " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 5) = "nach " Then
arrDatum(i) = "AFT " & Right(.Cells(i + 6, k), 4)
End If
If Left(.Cells(i + 6, k), 3) = "um " Then
arrDatum(i) = "ABT " & Right(.Cells(i + 6, k), 4)
End If
.Cells(i + 6, j) = arrDatum(i)
Next i
End With
End Sub
Ps.: das Ganze geht natürlich auch mit Select Case zu lösen. Ist eh dann nur noch eine Fleißaufgabe - dazu hatte ich keine Lust mehr, denn jetzt gibts ein wohlverdientes Adventsbier.