Sub Namensabgleich()
Dim i As Long, j As Byte, c As Range, NameX As String, arrNamen, Zaehler As Byte
For i = 2 To Range("C" & Rows.Count).End(xlUp).Row
Set c = Range("C" & i)
arrNamen = Split(c, ",")
Zaehler = 0
If Not IsEmpty(c) Then
For j = 0 To UBound(arrNamen)
NameX = Trim(arrNamen(j))
If Application.CountIf(Sheets("Tabelle2").Range("D:D"), NameX) > 0 Then
Zaehler = Zaehler + 1
If Zaehler > 1 Then
Range("E" & c.Row) = Range("E" & c.Row) & ", " & NameX
Else
Range("E" & c.Row) = "Name(n) in Tabelle2 vorhanden: " & vbLf & NameX
End If
End If
Next j
End If
Next i
End Sub
Viele Grüße
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Andy
Hallo Matthias,
danke für die Lösung.
Besteht auch die Möglichkeit die Namen in der Tabelle1 farblich zu kennzeichnet, statt die vorhandenen in einer neuer Spalte zu schreiben?
Gruß
Andy
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Matthias5
Hallo Andy,
ja das sollte kein Problem sein. Ich muss jetzt in eine Besprechung und melde mich nachher nochmal mit einem Vorschlag.
Bis dann
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Andy
Ok, danke.
mir ist wohl gerade noch aufgefallen, dass die Namen, die hinter einem ":" oder ";" stehen nicht mit bewertet werden; kann man hier noch weitere Trennzeichnen neben dem "," mit eintragen?
Gruß
Andy
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Matthias5
Hallo Andy,
so da bin ich wieder. Habe das Makro jetzt entsprechend angepasst. Die Trennzeichen kannst du gleich in der ersten Zeile des Makros ergänzen oder löschen.
Const Trennzeichen As String = ",;:."
Sub Namensabgleich()
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("C" & Rows.Count).End(xlUp).Row
Set c = Range("C" & i)
For k = 1 To Len(Trennzeichen)
arrNamen = Split(c, Mid(Trennzeichen, k, 1))
If Not IsEmpty(c) Then
For j = 0 To UBound(arrNamen)
NameX = Trim(arrNamen(j))
If Application.CountIf(Sheets("Tabelle2").Range("D:D"), NameX) > 0 Then
von = InStr(c, NameX)
bis = von + Len(NameX) - 1
With c.Characters(Start:=von, Length:=bis).Font
.Bold = True
.ColorIndex = 3
End With
End If
Next j
End If
Next k
Next i
End Sub
Gruß,
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Andy
Hallo Matthias,
danke für die Ergänzung, aber leider läuft der Code nicht durch. es werden ca 30 Namen erkannt, danach bricht er nach der 3 Zelle ab und meldet "Laufzeitfehler 13 - Typen unverträglich". Bei debuggen springt er er auf folgende Zeile:
If Application.CountIf(Sheets("Tabelle2").Range("D:D"), NameX) > 0 Then
mir sagt das leider nichts...
Vielleicht ne Idee?
Gruß
Andy
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Matthias5
Hi Andy,
ja das liegt an der Variable NameX. Wieviele Namen können denn maximal in einer Zelle stehen?
Gruß
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Andy
Hallo Matthias,
max 40 Namen stehen in einer Zelle.
Gruß Andy
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Matthias5
Hi nochmal,
war doch ein anderes Problem, ich hatte noch gar keine Fehlerbehandliung drin, falls das Trennzeichen nicht vorkommt. So sollte es gehen:
Const Trennzeichen As String = ",;:."
Sub Namensabgleich()
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("C" & Rows.Count).End(xlUp).Row
Set c = Range("C" & 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("Tabelle2").Range("D:D"), NameX) > 0 Then
von = InStr(c, NameX)
bis = von + Len(NameX) - 1
With c.Characters(Start:=von, Length:=bis).Font
.Bold = True
.ColorIndex = 3
End With
End If
Next j
End If
End If
Next k
Next i
End Sub
Gruß,
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Matthias5
Mannomann, habe noch einen Fehler entdeckt, melde mich später nochmal!
Gruß,
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Matthias5
Hi Andy,
hier mal ein Lösung, die funktioniert, wenn nicht verschiedene Trennzeichen in einer Zelle stehen:
Const Trennzeichen As String = ",;:."
Sub Namensabgleich()
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("C" & Rows.Count).End(xlUp).Row
Set c = Range("C" & 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("Tabelle2").Range("D:D"), NameX) > 0 Then
von = InStr(c, NameX)
bis = Len(NameX)
With c.Characters(Start:=von, Length:=bis).Font
.Bold = True
.ColorIndex = 3
End With
End If
Next j
End If
End If
Next k
Next i
End Sub
Gruß,
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
Andy
Hallo nochmal,
so, es funktionert soweit ganz gut, wenn man alle Zeichen ":"";" vorher in "," umwandelt - dann läuft es auch ganz durch und markiert alle.
Danke für Deine Hilfe!
Gruß
Andy
|
|
|
|