AW: Daten in mehreren Arbeitsmappen suchen
13.11.2010 01:25:28
fcs
Hallo Klaus,
bei mehreren Dateien muss man diese in einer Schleife abarbeiten.
Ich hab das Makro mal in diese Richtung angepasst. Die Dateien mit den Klassen-Erbenissen werden in einem Datei-Dialogfenster mit Mehrfachauswahl ausgewählt.
Ich bin jetzt davon ausgegangen, dass in den Ergebniss-Dateien alle Ergebnisse in einem Tabellenblatt stehen und die ID-Nummern immer in Spalte C ab Zeile 11 abwärts.
Gruß
Franz
Option Explicit
'# Windows Vista - Excel 2007 - VBA 6.5.1053 #
'# fcs 2010-11-12 #
'# Modul: Allgemeines Modul #
'# Daten aus mehreren Dateien suchen #
'# Makros sollten auch unter Excel 2000 - 2003 lauffähig sein #
Sub Datenabgleich_ID()
'Daten aus mehreren Dateien über ID-Nummer in Zieltabelle eintragen
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim iQuelle As Long, vQuelle As Variant, sQuelle As String, bQuelleOpen As Boolean
Dim vSchluessel
Dim lSpalteID_Quelle As Long, ZeileQuelle As Long, Zelle As Range
Dim lSpalteID_Ziel As Long, ZeileZiel As Long, rngID_Ziel As Range
'Arbeitsmappe/Tabelle in der Inhalte eingetragen werden sollen
Set wbZiel = Workbooks("Ergebnisliste.xls") 'oder = ActiveWorkbook 'Name anpassen!
Set wksZiel = wbZiel.Worksheets("Tabelle1") 'Name - anpassen
'Nrn. der Schlüsselspalten
lSpalteID_Ziel = 1 'Spalte A - ggf Anpassen
lSpalteID_Quelle = 3 'Spalte, sollte in allen Ergebnistabellen identisch sein - ggf Anpassen
If MsgBox("Vorhandene Ergebnis-Einträge in Spalte L löschen?", _
vbQuestion + vbYesNo, "Gesamt-Ergebnisliste aktualisieren") = vbYes Then
With wksZiel
.Range(.Cells(2, 12), .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 11)).ClearContents
'Bereich mit ID-Nummern in Zieltabelle
Set rngID_Ziel = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
End If
'Quelldateien auswählen
vQuelle = Application.GetOpenFilename( _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", _
Title:="Bitte alle Dateien mit Ergebnissen der Klassen auswählen", _
MultiSelect:=True)
If IsArray(vQuelle) = False Then Exit Sub 'Auswahldialog wurde abgebrochen
Application.ScreenUpdating = False
Application.EnableEvents = False
'ausgewählte Quell-Dateien abarbeiten
For iQuelle = LBound(vQuelle) To UBound(vQuelle)
sQuelle = vQuelle(iQuelle)
Application.StatusBar = "Datei " & iQuelle & " von " & UBound(vQuelle) _
& " (" & sQuelle & ") wird ausgewertet"
' MsgBox sQuelle, vbInformation + vbOKOnly, "Nächste auszuwertende Datei"
'Prüfen, ob Quelldatei schon geöffnet
If fncCheckWorkbook(strWorkbookName:=Mid(sQuelle, InStrRev(sQuelle, "\") + 1)) = True Then
bQuelleOpen = True
Set wbQuelle = Workbooks(Mid(sQuelle, InStrRev(sQuelle, "\") + 1))
Else
'Quelldatei öffnen
bQuelleOpen = False
Set wbQuelle = Workbooks.Open(Filename:=sQuelle, ReadOnly:=True)
End If
'Quelltabelle mit ggf. auszulesenden Daten setzen
Set wksQuelle = wbQuelle.Worksheets(1) 'ggf. Indexnummer oder Name in _
Anführungszeichen anpassen
With wksQuelle
'Letzte Datenzeile in Quelltabelle
ZeileQuelle = .Cells(.Rows.Count, lSpalteID_Quelle).End(xlUp).Row
For ZeileQuelle = 11 To ZeileQuelle
'Such-Werte aus Zeile in Quelltabelle einlesen
vSchluessel = .Cells(ZeileQuelle, lSpalteID_Quelle)
If vSchluessel "" Then
'ID in Zieltabelle in Schlüsselspalte suchen
Set Zelle = rngID_Ziel.Find(what:=vSchluessel, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
'ID in Ziel nicht vorhanden
MsgBox "ID " & vSchluessel & " in Datei """ & wbQuelle.Name _
& """ in der Zieltabelle nicht vorhanden!", vbInformation + vbOKOnly, _
"Gesamt-Ergebnisliste aktualisieren"
Else
ZeileZiel = Zelle.Row
'Daten aus Quelle in Spalte AN (40) in Ziel in Spalte L (12) eintragen
wksZiel.Cells(ZeileZiel, 12).Value = .Cells(ZeileQuelle, 40).Value
'usw.
End If
End If
Next
End With
'Quelldatei ggf. wieder schliessen
If bQuelleOpen = False Then wbQuelle.Close savechanges:=False
Next
wbZiel.Activate
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Gesamt-Ergebnisliste fertig", vbInformation + vbOKOnly, "Einlesen Ergebnisse"
End Sub
Function fncCheckWorkbook(strWorkbookName As String) As Boolean
'Prüft, ob Arbeitsmappe schon geöffnet
Dim wb As Workbook
For Each wb In Workbooks
If LCase(wb.Name) = LCase(strWorkbookName) Then
fncCheckWorkbook = True
Exit For
End If
Next
End Function