|
Hi Marc,
Probier mal den folgenden Code:
Sub Suffix()
Dim rng As Range, c As Range, f As Range
Dim i As Long, k As Long, x As Long
Set rng = Range("G1", Cells(Rows.Count, "G").End(xlUp))
k = 1
Cells(1, "A") = Cells(1, "A") & "_" & k
For Each c In rng.Cells
i = i + 1
If i > 1 Then
If c <> c.Offset(-1) Then
Set f = Range(rng.Cells(1), rng.Cells(c.Row - rng.Row)).Find(c, lookat:=xlWhole)
If f Is Nothing Then
k = k + 1
Cells(c.Row, "A") = Cells(c.Row, "A") & "_" & k
Else
x = Right(Cells(f.Row, "A"), Len(Cells(f.Row, "A")) - InStrRev(Cells(f.Row, "A"), "_"))
Cells(c.Row, "A") = Cells(c.Row, "A") & "_" & x
End If
Else
Cells(c.Row, "A") = Cells(c.Row, "A") & "_" & k
End If
End If
Next c
End Sub
Gruß Mr. K.
|