AW: Namenskürzel ohne Zahlen generieren...
21.09.2005 15:20:35
Heinz
Hallo NIKI,
hier ein Versuch mit 4 Stellen. Ich habe das mit über 4000 Namen getestet.
Zuerst hatte ich nur die ersten vier Stellen, dann die ersten drei + die jeweils nächsten des Namens und Vornamens. Eas gab aber immer noch ca. 300 Fehler.
Mit der vorliegenden Version habe ich noch drei. Vielleicht kommst du mit deinen Daten durch?
Sub CodeErstellen()
Dim lz%, z As Range, cod$, erledigt As Boolean, gef As Range, i%
lz = Cells(Rows.Count, 1).End(xlUp).Row
For Each z In Range("A2:A" & lz)
erledigt = False
cod = UCase(Left(z.Value & z.Offset(0, 1).Value, 4))
Set gef = Range("C:C").Find(cod)
If gef Is Nothing Then
z.Offset(0, 2).Value = cod
erledigt = True
Else
For i = 5 To Len(z.Value & z.Offset(0, 1).Value)
cod = UCase(Left(z.Value & z.Offset(0, 1).Value, 3) & Mid(z.Value & z.Offset(0, 1).Value, i, 1))
Set gef = Range("C:C").Find(cod)
If gef Is Nothing Then
z.Offset(0, 2).Value = cod
erledigt = True
Exit For
End If
Next i
If erledigt = False Then
For i = 2 To Len(z.Value & z.Offset(0, 1).Value)
cod = UCase(Left(z.Value & z.Offset(0, 1).Value, 1) & Mid(z.Value & z.Offset(0, 1).Value, 3, 2) & Mid(z.Value & z.Offset(0, 1).Value, i, 1))
Set gef = Range("C:C").Find(cod)
If gef Is Nothing Then
z.Offset(0, 2).Value = cod
erledigt = True
Exit For
End If
Next i
End If
If erledigt = False Then
For i = 4 To Len(z.Value & z.Offset(0, 1).Value)
cod = UCase(Left(z.Value & z.Offset(0, 2).Value, 1) & Mid(z.Value & z.Offset(0, 1).Value, 4, 1) & Mid(z.Value & z.Offset(0, 1).Value, i, 1))
Set gef = Range("C:C").Find(cod)
If gef Is Nothing Then
z.Offset(0, 2).Value = cod
erledigt = True
Exit For
End If
Next i
End If
End If
If erledigt = False Then _
z.Offset(0, 2).Value = "KEIN CODE GEFUNDEN!"
Next z
End Sub
Name steht in der Spalte A, Vorname in B, der Code dann in C.
Gruß
Heinz