Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1068to1072
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

2 TabellenBlätter vergleichen - gleiche markieren

2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 11:44:02
Andy
Hallo,
ich habe 2 unterschiedliche Tabellen in denen ein Mitgliederabgleich durch geführt werden soll.
In der Tabelle1 sind die Namen der Mitglieder einer Gruppe zusammen in einer Zelle hinter einander geschrieben; in der der Tabelle2 sind alle Mitglieder unter einander (jeweils neue Zeile) aufgezählt.
Ich möchte nun in der Tabelle1 überprüfen, welche Mitglieder auch in der Tabelle2 vorhanden sind; diese sollen markiert werden (Vorname+Nachname)
In Tabelle2 findet eine Abfrage statt, ob das Mitglied in Tabelle1 vorhanden ist; hier habe ich die Abfrage mittels Formel und Bedingter Formatierung bereits zufriedenstellend realisieren können.
Den Aufbau der Datei findet ihr im beigefügten Beispiel:
https://www.herber.de/bbs/user/61228.xls
Ich denke, dass sich die Abfrage für Tabelle1 wahrscheinlich nur über VBA, daher würde ich mich über euere Hilfe freuen.
Danke!
Gruß
Andy

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 12:30:56
Matthias5
Hallo Andy,
hier mal ein VBA-Vorschlag:
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
Anzeige
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 13:16:45
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
16.04.2009 14:05:28
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
16.04.2009 14:11:52
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
16.04.2009 16:15:11
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
Anzeige
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 17:17:32
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
16.04.2009 18:53:00
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
16.04.2009 22:25:41
Andy
Hallo Matthias,
max 40 Namen stehen in einer Zelle.
Gruß Andy
Anzeige
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 19:20:49
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
Anzeige
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 20:44:39
Matthias5
Mannomann, habe noch einen Fehler entdeckt, melde mich später nochmal!
Gruß,
Matthias
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 21:18:20
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
Anzeige
AW: 2 TabellenBlätter vergleichen - gleiche markieren
16.04.2009 22:49:37
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

316 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige