Werte aus 2 Dateien vergleichen und bei übereinstimmendem Kriterium kopieren

Question

Hallo zusammen,

ich habe ein etwas komplexeres Excel-Problem bei dem ich mit
minen rudimentären Kenntnissen nicht weiter kommen.


Ich versuche das Problem mal zu schildern:

Es gibt 2 Excel-Dateien (Mappe1.xls + Mappe2.xls) mit jeweils einem
Arbeitsblatt, Name jeweils Tabelle1.

In Mappe1.xls gibt Einträge in mehreren Spalten (A-M), in der Spalte
A steht eine Kundennummer, jede Nummer kommt nur einmal vor.

In Mappe2.xls gibt es ebenfalls mehrere Spalten (A-E), in Spalte A
steht die Kundennummer. In der Spalte E steht evtl. eine Ziffer (1 bis
4).


Nun die Anforderung:

Eine neue Exceltabelle (oder ein neues Sheet..) soll befüllt werden.
Dafür soll Mappe1.xls Zeile für Zeile durchsucht und mit Mappe2.xls
abgeglichen werden:
Wenn die Kundenummer aus der untersuchten Zeile (Mappe1.xls) in
einer beliebigen Zeile in Spalte A in Mappe2.xls gefunden wird, soll
die
gesamte untersuchte Zeile aus Mappe1.xls in die neue Tabelle
geschrieben werden, aber NUR wenn in der gefundenen Zeile in
Spalte E (in Mappe2.xls) eine "1" steht.
Wenn nicht, soll die nächste Zeile aus Mappe1.xls untersucht
werden und zwar so lange bis in Mappe1.xls keine weitere Zeile mit
Inhalt gefunden wird...

Hoffentlich habe ich mein Problem verständlich geschildert und
hoffentlich hat jemand einen Lösungsansatz mit dem ich
experimentieren kann!

Schon mal einen lieben Dank!


Gruß, Matthias

Answer 1

Hallo Matthias,

das folgende Makro gehört in ein Standard-Modul deiner Mappe1:

Sub kopieren()

Dim strQuelle As String
Dim strPfad As String
Dim strZielblatt As String
Dim lnglzQuelle As Long
Dim lnglzZiel As Long
Dim lngQZeile As Long
Dim lngZZeile As Long
Dim lngEinfZeile As Long
Dim i As Long
Dim bExists As Boolean

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Pfad für Quelldatei - Quelldatei liegt im selben Verzeichnis wie diese Datei; falls nicht Pfad anpassen; Bsp: strPath = "C:\Test\"
strPfad = ThisWorkbook.Path

'Name des Blattes festlegen, in das die Datensätze kopiert werden sollen
strZielblatt = "Auswertung"

'Prüfen, ob das Blatt existiert
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = strZielblatt Then
bExists = True
Exit For
End If
Next i

'falls das Arbeitsblatt nicht existiert, dann anlegen
If bExists = False Then
'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = strZielblatt
End If

'Quelldatei öffenen - Name der Datei ggf. anpassen
Workbooks.Open (strPath & "Mappe2.xlsx")

'Name der geöffneten Mappe wird in Variable geschrieben
strQuelle = ActiveWorkbook.Name

'letzte Zeile in Spalte A der Tabelle1 der Quelldatei ermitteln
lnglzQuelle = Workbooks(strQuelle).Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row

'letzte Zeile in Spalte A der Tabelle1 der Zieldatei ermitteln
lnglzZiel = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row

'Kundennummern ab Zeile 2 durchgehen
For lngZZeile = 2 To lnglzZiel
'mit Kundennummern in Quelltabelle ab Zeile 2 vergleichen
For lngQZeile = 2 To lnglzQuelle
If ThisWorkbook.Worksheets("Tabelle1").Cells(lngZZeile, 1) = Workbooks(strQuelle).Worksheets("Tabelle1").Cells(lngQZeile, 1) And Workbooks(strQuelle).Worksheets("Tabelle1").Cells(lngQZeile, 5).Value = 1 Then
'Einfügezeile im Zielarbeitsblatt ermitteln
lngEinfZeile = ThisWorkbook.Worksheets(strZielblatt).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Daten kopieren
Workbooks(strQuelle).Worksheets("Tabelle1").Rows(lngZZeile).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(lngEinfZeile, 1)
End If
Next lngQZeile
Next lngZZeile

'Quelldatei schließen
Workbooks(strQuelle).Close (False)

'Auf Ausgabeblatt wechseln
ThisWorkbook.Worksheets(strZielblatt).Activate

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Ich gehe davon aus, dass die beiden Mappen im selben Verzeichnis gespeichert sind. Falls nicht musst du den Pfad entsprechend anpassen (siehe Kommentierung im Makro).
Die gefundenen Daten werden in ein neues Arbeitsblatt in der Mappe1 kopiert. Existiert das Tabellenblatt schon, werden die Daten an eventuell vorhandene Daten angefügt.

Gruß

M.O.

Answer 2

Hallo,

im Code ist noch ein Fehler drin. Ersetze die Zeile

Workbooks(strQuelle).Worksheets("Tabelle1").Rows(lngZZeile).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(lngEinfZeile, 1)

durch

Workbooks(strQuelle).Worksheets("Tabelle1").Rows(lngQZeile).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(lngEinfZeile, 1)

Gruß
M.O.

Answer 3

Hmm.

geht das nicht auch einfach mit dem =SVERWEIS (....

cu
R

Answer 4

Hallo M.O.,

vielen lieben Dank für deinen Einsatz!
Ich werde das gleich nachher daheim ausprobieren und dann berichten!

PS: Meine Ansätze von wegen vergleichen verweis etc. kann ich ja wohl alle vergessen .....

Gruß, Matthias

Answer 5

Hallo Matthias,

wenn du das per Formel lösen willst, dann schau dir mal das hier an: KLICK MICH!.

@ Roland
Das geht leider nicht einfach mit SVERWEIS, da 2 Suchkriterien und ggf. mehrere Ergebnisse (?).

Gruß

M.O.

Answer 6

Ok...
Ich habe mich jetzt mal ein wenig mit deiner Lösung beschäftigt und folgendes festgestellt:

Die Neuerstellung des Worksheet Auswertung klappt.
Aber dann steigt das Makro mit "Laufzeitfehler 9.. Index außerhalb des gültigen Bereichs" in der Zeile
'letzte Zeile in Spalte A der Tabelle1 der Zieldatei ermitteln
lnglzZiel = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
aus...

Außerdem habe ich mein Problem glaub ich doch nicht anschaulich genug geschildert..

Inhalt Mappe2.xlsx, Tabelle1:
A B C D
Kundennummer Name C D
00442-14 Mustertyp 161,15 €
00443-14 Mustermann 4711 107,54 €
00444-14 Musterbild 815 107,54 €
00446-14 Musterblume 1235 96,96 €
00448-14 Musterbla 847 161,53 €



Inhalt Mappe1.xlsx, Tabelle1:
A B C D E
Kundennummer Name Feld 1 Feld 2 Notizen1
00442-14 Muster 1 WER
00443-14 Muster 2 WER 1
00444-14 Muster 3 WER
00446-14 Muster 4 WER 1
00448-14 Muster 5 WER
00449-14 Muster 6 WER


Nun soll in die neue Tabelle (Auswertung) die gesamte Zeile die mit 00443-14 und die gesamte Zeile die mit 00446-14 beginnt aus der Mappe2.xlsx kopiert werden.
Denn bei nur bei genau diesen Kundennummern existiert in Mappe1.xlsx in Spalte E die Ziffer 1.....


M.O. , wärst du so nett deine Lösung nochmal anzupassen?

Link für Beispiel Mappe1: https://www.dropbox.com/s/uwtc38yfbhq2wqv/Mappe1.xlsx?dl=0
Link für Beispiel Mappe2: https://www.dropbox.com/s/yo070vtifnjpge5/Mappe2.xlsx?dl=0

Answer 7

Hallo Matthias,

habe ich das richtig verstanden, die neue Tabelle Auswertung soll so aussehen:

00443-14 Mustermann 4711 107,54 € 00443-14 Muster 2 WER 1
(wobei man sich die zweite Kundennummer sparen könnte).

Gruß

M.O.

Answer 8

Hallo Matthias,

das Makro musst du in ein allgemeines Modul deiner Mappe2 kopieren:

Sub kopieren()

Dim strQuelle As String
Dim strPfad As String
Dim strZielblatt As String
Dim lnglzQuelle As Long
Dim lnglzZiel As Long
Dim lngQZeile As Long
Dim lngZZeile As Long
Dim lngEinfZeile As Long
Dim i As Long
Dim bExists As Boolean

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Pfad für Quelldatei - Quelldatei liegt im selben Verzeichnis wie diese Datei; falls nicht Pfad anpassen; Bsp: strPath = "C:\Test\"
strPfad = ThisWorkbook.Path

'Name des Blattes festlegen, in das die Datensätze kopiert werden sollen
strZielblatt = "Auswertung"

'Prüfen, ob das Blatt existiert
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = strZielblatt Then
bExists = True
Exit For
End If
Next i

'falls das Arbeitsblatt nicht existiert, dann anlegen
If bExists = False Then
'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = strZielblatt
End If

'Quelldatei öffenen - Name der Datei ggf. anpassen
Workbooks.Open (strPath & "Mappe1.xlsx")

'Name der geöffneten Mappe wird in Variable geschrieben
strQuelle = ActiveWorkbook.Name

'Überschriften kopieren, falls Blatt neu angelegt wird
If bExists = False Then
ThisWorkbook.Worksheets("Tabelle1").Rows(1).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(1, 1) 'Überschrift aus dieser Datei aus Zeile 1
Workbooks(strQuelle).Worksheets("Tabelle1").Range(Cells(6, 2), Cells(6, 5)).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(1, 14) 'Überschrift steht in Zeile 6, ohne Kundennummer
End If

'letzte Zeile in Spalte A der Tabelle1 der Quelldatei ermitteln
lnglzQuelle = Workbooks(strQuelle).Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row

'letzte Zeile in Spalte A der Tabelle1 der Zieldatei ermitteln
lnglzZiel = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row

'Kundennummern ab Zeile 2 durchgehen
For lngZZeile = 3 To lnglzZiel
'mit Kundennummern in Quelltabelle ab Zeile 2 vergleichen
For lngQZeile = 7 To lnglzQuelle
If ThisWorkbook.Worksheets("Tabelle1").Cells(lngZZeile, 1) = Workbooks(strQuelle).Worksheets("Tabelle1").Cells(lngQZeile, 1) And Workbooks(strQuelle).Worksheets("Tabelle1").Cells(lngQZeile, 5).Value = 1 Then
'Einfügezeile im Zielarbeitsblatt ermitteln
lngEinfZeile = ThisWorkbook.Worksheets(strZielblatt).Cells(Rows.Count, 1).End(xlUp).Row + 1
'Daten kopieren
'aus Tabelle in Auswertung
ThisWorkbook.Worksheets("Tabelle1").Rows(lngZZeile).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(lngEinfZeile, 1)
'aus Quelledatei; falls Kundennummer mitkopiert werden soll muss Folgendes geändert werden: Range(Cells(lngQZeile, 1), Cells(lngQZeile, 5)
Workbooks(strQuelle).Worksheets("Tabelle1").Range(Cells(lngQZeile, 2), Cells(lngQZeile, 5)).Copy Destination:=ThisWorkbook.Worksheets(strZielblatt).Cells(lngEinfZeile, 14)
End If
Next lngQZeile
Next lngZZeile

'Quelldatei schließen
Workbooks(strQuelle).Close (False)

'Auf Ausgabeblatt wechseln
ThisWorkbook.Worksheets(strZielblatt).Activate

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Ich habe das Makro entsprechend deinen Beispieldateien angepasst.

Gruß

M.O.

Answer 9

M.O. , du bist genial!
Das funktioniert 100%, vielen,vielen Dank!
Damit rettest du mir so manchen Feierabend!

Gruß,Matthias

Answer 10

Hallo Matthias,

danke für die Rückmeldung :-).

Gruß

M.O.