AW: Such Makro über mehrere Dateien
15.08.2007 16:07:04
Chaos
Servus Dominik,
hier mal ein Ansatz, wie sowas ausschauen könnte:
Das Makro sucht in zeile 1 der jeweiligen Datien das Wort Kundennummer und vergleicht dann die Einträge, sind die Einträge in beiden dateien vorhanden, dann wird in der Ausgangsdatei das Suchergebnis in Tabelle Suchergebnis widergegeben.
Sub suchever()
Dim zquelle As Long, rquelle As Long, spquelle As Long, spquelleneu As Long, rowquelle As Long
Dim nquelle As String, quellead As String, quelleadb As String
Dim row As Long, zeile As Long
row = Sheets(3).Range("a65536").End(xlUp).Offset(0, 0).row
For zeile = 2 To row Step 1 ' Löschschleife in Suchergebnis
Sheets(3).Cells(zeile, 1).EntireRow.ClearContents
Next zeile
nquelle = ThisWorkbook.Name ' Ermittlung der Quellinformationen
For spquelle = 1 To 200 Step 1
If Workbooks(nquelle).Sheets(1).Cells(1, spquelle).Value = "Kundennummer" Then ' Suche _
nach Kundennummer
quellead = Workbooks(nquelle).Sheets(1).Cells(1, spquelle).Address(0, 0) ' Adresse _
auslesen
With WorksheetFunction
quelleadb = .Substitute(quellead, 1, "")
rowquelle = Workbooks(nquelle).Sheets(1).Range(quelleadb & "65536").End(xlUp). _
Offset(0, 0).row ' letzte beschriebene zelle finden
End With
spquelleneu = Workbooks(nquelle).Sheets(1).Cells(1, spquelle).Column
Exit For
End If
Next spquelle
Workbooks.Open Filename:="C:\Dokumente und Einstellungen\Christian\Desktop\45097.xls" ' _
Zieldatei öffnen / Pfad anpassen
Dim nziel As String, zielad As String, zieladb As String
Dim zziel As Long, rziel As Long, spziel As Long, spzielneu As Long, rowziel As Long
nziel = ActiveWorkbook.Name ' Hier das selbe Spiel wie oben für die Zieldatei
For spziel = 1 To 256 Step 1
If Workbooks(nziel).Sheets(1).Cells(1, spziel).Value = "Kundennummer" Then
zielad = Workbooks(nziel).Sheets(1).Cells(1, spziel).Address(0, 0)
With WorksheetFunction
zieladb = .Substitute(zielad, 1, "")
rowziel = Workbooks(nziel).Sheets(1).Range(zieladb & "65536").End(xlUp).Offset( _
0, 0).row
End With
spzielneu = Workbooks(nziel).Sheets(1).Cells(1, spziel).Column
Exit For
End If
Next spziel
Dim verquelle As Long, verziel As Long ' Vergleich in den ermittelten Grenzen
For verquelle = 2 To rowquelle Step 1
For verziel = 2 To rowziel Step 1
If Workbooks(nquelle).Sheets(1).Cells(verquelle, spquelleneu).Value = _
Workbooks(nziel).Sheets(1).Cells(verziel, spzielneu).Value Then
Workbooks(nquelle).Sheets(1).Cells(verquelle, spquelleneu).EntireRow.Copy _
Workbooks(nquelle).Sheets(3).Range("A65536").End(xlUp).Offset(1, 0)
End If
Next verziel
Next verquelle
Workbooks(nziel).Close
Workbooks(nquelle).Sheets(3).Activate
End Sub
Ist jetz nur für eine Zieldatei, also 2 Dateien. Für die andere Datei musst du das genauso aufbauen (2.Block) und dann mit den neu ermittelten Werten einen Vergleich (Werte aus Block 1 bleiben gleich) starten
Gruß
Chaos