VBA Mitgliederabgleich markiert nur einfach
Andy
mit dem folgenden Code möchte ich gerne einen Mitgliederabgleich zwischen einer Torschützenliste und der Mitgliederdaten machen. Die Torschützen befinden sich im Blatt Torschützen in der Spalte D:D und sind alle jeweils in einer Zelle durch Komma getrennt eingetragen; die Mitglieder stehen im Blatt Mitglieder in der Spalte E:E. Die Übereinstimmungen werden im Blatt Torschützenliste Grün markiert.
Der Code läuft soweit, aber er markiert mir die Toschützen in der Zelle nur max. einmal!
Wer kann mir hier weiterhelfen?
Const Trennzeichen As String = ",;:."
Sub Namensabgleich()
Sheets("Torschützen").Select
Columns("D:D").Select
Dim i As Long, j As Byte, c As Range, NameX As String, arrNamen
Dim von As Integer, bis As Integer, k As Byte
For i = 2 To Range("D" & Rows.Count).End(xlUp).Row
Set c = Range("D" & i)
For k = 1 To Len(Trennzeichen)
arrNamen = Split(c, Mid(Trennzeichen, k, 1))
If Not IsEmpty(c) Then
If UBound(arrNamen) > 0 Then
For j = 0 To UBound(arrNamen)
NameX = Trim(arrNamen(j))
If Application.CountIf(Sheets("Mitglieder").Range("E:E"), NameX) > 0 Then
von = InStr(c, NameX)
bis = Len(NameX)
With c.Characters(Start:=von, Length:=bis).Font
'.Bold = True
.ColorIndex = 4
End With
End If
Next j
End If
End If
Next k
Next i
End SubGruß
Andy
Anzeige