Option Explicit
Sub kürzel()
Dim namen()
Dim kürzel()
Dim ende As Long
Dim i As Long
Dim anzahl As Long
ende = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
ReDim namen(0)
ReDim kürzel(0)
anzahl = 0
For i = 1 To ende
If ActiveSheet.Cells(i, 2) <> "" Then
If UBound(Filter(namen, ActiveSheet.Cells(i, 2))) > -1 Then
ActiveSheet.Cells(i, 3) = kürzel(Application.Match(ActiveSheet.Cells(i, 2), namen, False) - 1)
Else
anzahl = anzahl + 1
ReDim Preserve namen(anzahl)
ReDim Preserve kürzel(anzahl)
namen(anzahl) = ActiveSheet.Cells(i, 2)
kürzel(anzahl) = "A" & anzahl
ActiveSheet.Cells(i, 3) = "A" & anzahl
End If
End If
Next i
End Sub