unterschiedliche Kundenlisten abgleichen und Zeile

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Vergleich() Dim ListAbgleich1(), ListAbgleich2() Dim ArListe1PLZ, ArListe1Name, ArListe2PLZ, ArListe2Name Dim n&, nn&, varValue, varValues With Tabelle1 'Tabelle anpassen With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow ArListe1PLZ = .Columns(1).Resize(, 2) 'Spalte PLZ ArListe1Name = .Columns(2).Resize(, 2) 'Spalte Firmenname End With End With With Tabelle2 'Tabelle anpassen With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow ArListe2PLZ = .Columns(1).Resize(, 2) 'Spalte PLZ ArListe2Name = .Columns(2).Resize(, 2) 'Spalte Firmenname End With End With Redim Preserve ListAbgleich1(1 To Ubound(ArListe1PLZ), 1 To 1) Redim Preserve ListAbgleich2(1 To Ubound(ArListe2PLZ), 1 To 1) For n = 1 To Ubound(ArListe1PLZ) For nn = 1 To Ubound(ArListe2PLZ) If ArListe1PLZ(n, 1) = ArListe2PLZ(nn, 1) Then varValues = Split(ArListe1Name(n, 1), " ") For Each varValue In varValues If InStr(ArListe2Name(nn, 1), varValue) > 0 Then ListAbgleich1(n, 1) = ArListe2Name(nn, 1) ListAbgleich2(n, 1) = ArListe1Name(n, 1) Exit For End If Next varValue End If Next nn Next n 'Ausgabe ***************************************************** With Tabelle1 'Tabelle anpassen 'erste Zelle anpassen .Range("C2").Resize(Ubound(ListAbgleich1)) = ListAbgleich1 End With With Tabelle2 'Tabelle anpassen 'erste Zelle anpassen .Range("C2").Resize(Ubound(ListAbgleich2)) = ListAbgleich2 End With End Sub

Hallo,
ok. kannst mal so versuchen.
kommt als Code in Modul1

Option Explicit 
 
Sub Vergleich() 
Dim ListAbgleich1() 
Dim ArListe1PLZ, ArListe1Name, ArListe2 
Dim n&, nn&, nnn&, varValue, varValues 
Dim oWSListe1 As Worksheet, oWSListe2 As Worksheet 
 
Set oWSListe1 = Tabelle1 'Tabelle Liste 1 
Set oWSListe2 = Tabelle2 'Tabelle Liste 2 
 
Const SpPLZ_Liste1& = 4 'Spalte PLZ Liste1 
Const SpName_Liste1& = 2 'Spalte Name Liste1 
 
Const SpPLZ_Liste2& = 7 'Spalte PLZ Liste2 
Const SpName_Liste2& = 4 'Spalte Name Liste2 
 
  
With oWSListe1 'Tabelle anpassen 
    With .Range(.Cells(2, SpPLZ_Liste1), .Cells(.Rows.Count, SpPLZ_Liste1).End(xlUp)).EntireRow 
        ArListe1PLZ = .Columns(SpPLZ_Liste1).Resize(, 2) 'Spalte PLZ 
        ArListe1Name = .Columns(SpName_Liste1).Resize(, 2) 'Spalte Firmenname 
    End With 
End With 
  
With oWSListe2 'Tabelle anpassen 
    With .Range(.Cells(2, SpPLZ_Liste2), .Cells(.Rows.Count, SpPLZ_Liste2).End(xlUp)).EntireRow 
        ArListe2 = .Cells(1, 1).Resize(.Rows.Count, 10) 
    End With 
End With 
  
Redim Preserve ListAbgleich1(1 To Ubound(ArListe1PLZ), 1 To Ubound(ArListe2, 2)) 
    
For n = 1 To Ubound(ArListe1PLZ) 
      For nn = 1 To Ubound(ArListe2) 
          If ArListe1PLZ(n, 1) = ArListe2(nn, SpPLZ_Liste2) Then 
              varValues = Split(ArListe1Name(n, 1), " ") 
              For Each varValue In varValues 
                  If InStr(ArListe2(nn, SpName_Liste2), varValue) > 0 Then 
                     For nnn = 1 To Ubound(ArListe2, 2) 
                        ListAbgleich1(n, nnn) = ArListe2(nn, nnn) 
                     Next nnn 
                     Exit For 
                  End If 
              Next varValue 
          End If 
      Next nn 
Next n 
  
'Ausgabe ***************************************************** 
With oWSListe1 'Tabelle anpassen 
    'erste Zelle anpassen 
    .Range("H2").Resize(Ubound(ListAbgleich1), Ubound(ListAbgleich1, 2)) = ListAbgleich1 
End With 
 
End Sub

Gruß Tino

Hallo Tino,
vielen Dank für deine Mühe und die Musterdatei.
Ich habe mich nach und nach hineingearbeitet. Ein paar Sachen funktionieren,wenn ich meine Kundendaten hineinkopiere noch nicht.
Die Übernahme der Fantasienamen klappt hunderprozentig. Wenn ich meine Kundendaten in Tabelle1 und in Tabelle2 eingefügt habe, werden nicht alle Kunden korrekt übernommen.
Aufgefallen ist mir, wenn in Tabelle1 hinter dem Namen ein oder mehrere Leerschritte sind,werden die Daten nicht mehr richtig übernommen. Ich habe dir die entsprechenden Zeilen farbig markiert (rot = falsch, grün oder nicht markiert = richtig).
Kannst du das im Code abändern?
Wo muss ich den Code ändern, wenn ich mehr Spalten aus Tabelle2 in Tabelle1 übernehmen möchte? Die folgenden Zahlen änderte ich auf die entsprechenden Spalten ab
Const SpPLZ_Liste1& = 4 'Spalte PLZ Liste1
Const SpName_Liste1& = 2 'Spalte Name Liste1
Const SpPLZ_Liste2& = 7 'Spalte PLZ Liste2
Const SpName_Liste2& = 4 'Spalte Name Liste2
.Range("H" & varRowL1 + 1).Resize(UBound(ListAbgleich1), UBound(ListAbgleich1, 2)) = ListAbgleich1
rngHeader.Copy .Range("H" & varRowL1)
With .Range("H" & varRowL1).Resize(, 10)
änderte nur nichts beim Einfügen.
Kann ich den blauen "Ausführungs" Button einfach in eine andere Liste kopieren?
Hier die bearbeitete Musterdatei

Die Datei https://www.herber.de/bbs/user/94171.xlsm wurde aus Datenschutzgründen gelöscht

Super vielen Dank für deine Arbeit.
Gruß Jörg

Beliebteste Forumthreads (12 Monate)

unterschiedliche Kundenlisten abgleichen und Zeile

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

unterschiedliche Kundenlisten abgleichen und Zeile

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread