PDA

Vollständige Version anzeigen : Ausgabe zweier Tabellen nach Abgleich


Siagnum
27.09.2016, 14:16
Hallo alle zusammen,
Ich habe ein Beispiel als Anhang hinzugefügt.
Ausgangssituation ist das Klick! und Media! mit Daten befüllt sind.
Es soll ein Abgleich zwischen Klick! und Media! stattfinden und zwar wie folgt:
Prüfe: Vorname+Nachname+Straße in beiden Tabellen auf Übereinstimmung. Falls Übereinstimmung vorhanden:Anrede+Vorname+Nachname+Straße+PLZ+Ort+Vorwahl+Telefon aus Klick! mit zugehöriger Kundennummer aus Media! in (neuerstellte Tabelle)Ziel! ausgeben.
Ich verzweifle bei der Lösung dieses Problems, ich habe es mit Sverweis probiert, allerdings dauert die Berechnung ewig und es scheint mir auch nicht der beste Weg zu sein.

Ich danke Vielmals für eure Hilfe
Gruß Marko

Benutzername:
27.09.2016, 15:49
Tach Michael,

ich habs mal Quick and Dirty mit 2 Schleifen gelöst, probier mal ob es so taugt.

Gruss,
Stephan


Option Explicit

Sub Datenabgleich()

Application.ScreenUpdating = False

'letzte Zeilen auslesen
Dim lastRowKlick As Long
lastRowKlick = Worksheets("Klick").Range("A" & Rows.Count).End(xlUp).Row

Dim lastRowMedia As Long
lastRowMedia = Worksheets("Media").Range("A" & Rows.Count).End(xlUp).Row

Dim lastRowZiel As Long
lastRowZiel = Worksheets("Ziel").Range("A" & Rows.Count).End(xlUp).Row

'namen aus klick auslesen
Dim i As Long
For i = 2 To lastRowKlick


Dim vorname, nachname As String
vorname = Worksheets("Klick").Cells(i, 2).Value
nachname = Worksheets("Klick").Cells(i, 3).Value

'nur wenn beides nicht leer ist
If vorname <> "" And nachname <> "" Then

'namen aus media auslesen
Dim j As Long
For j = 2 To lastRowMedia

'namensvergleich
If vorname = Worksheets("Media").Cells(j, 1).Value And nachname = Worksheets("Media").Cells(j, 2).Value Then

'werte kopieren
lastRowZiel = lastRowZiel + 1

Worksheets("Ziel").Cells(lastRowZiel, 1) = Worksheets("Klick").Cells(i, 1).Value
Worksheets("Ziel").Cells(lastRowZiel, 2) = Worksheets("Klick").Cells(i, 2).Value
Worksheets("Ziel").Cells(lastRowZiel, 3) = Worksheets("Klick").Cells(i, 3).Value
Worksheets("Ziel").Cells(lastRowZiel, 4) = Worksheets("Klick").Cells(i, 4).Value
Worksheets("Ziel").Cells(lastRowZiel, 5) = Worksheets("Klick").Cells(i, 5).Value
Worksheets("Ziel").Cells(lastRowZiel, 6) = Worksheets("Klick").Cells(i, 6).Value
Worksheets("Ziel").Cells(lastRowZiel, 7) = Worksheets("Klick").Cells(i, 7).Value
Worksheets("Ziel").Cells(lastRowZiel, 8) = Worksheets("Klick").Cells(i, 8).Value

Worksheets("Ziel").Cells(lastRowZiel, 9) = Worksheets("Media").Cells(j, 4).Value

End If
Next j

End If

Next i

Application.ScreenUpdating = True

End Sub

Siagnum
27.09.2016, 17:52
Funktioniert super =) Vielen Dank

Lg Marko

Benutzername:
27.09.2016, 18:34
Servus Marko,

oki, super.

Sorry wegen "Michael", hatte geraten wegen Excelfileautor ;)

Gruss,
Stephan