AW: Werte aus mehreren Dateien auslesen
06.05.2010 07:32:03
fcs
Hallo Enrico,
Hier mal das Grundgerüst zum Abarbeiten der Dateiliste und Suchen der Daten.
Für die Daten wird ein neues Tabellenblatt angelegt.
Gruß
Franz
Sub DatenEinlesen()
Dim wksListe As Worksheet, ZeileListe As Long, ZeileL As Long
Dim wksZiel As Worksheet, ZeileZ As Long
Dim wbQuelle As Workbook, wksQuelle As Worksheet, Zelle As Range
Dim sDateiname As String
Set wksListe = ActiveWorkbook.Worksheets("Dateiliste")
Set wksZiel = ActiveWorkbook.Worksheets.Add
ZeileZ = 1
'Spaltentitel eintragen
wksZiel.Cells(ZeileZ, 1) = "Dateiname"
wksZiel.Cells(ZeileZ, 2) = "Tabellenname"
wksZiel.Cells(ZeileZ, 3) = "Datum"
wksZiel.Cells(ZeileZ, 4) = "Name"
wksZiel.Cells(ZeileZ, 5) = "Faktor"
'usw.
Range("A2").Select
ActiveWindow.FreezePanes = True
'Dateinamen in Liste abarbeiten
Application.ScreenUpdating = False
With wksListe
'Letzte Zeile in Liste
ZeileL = .Cells(.Rows.Count, 1).End(xlUp).Row
For ZeileListe = 2 To ZeileL
Application.StatusBar = "Bearbeite Zeile " & ZeileListe & " von " & ZeileL
sDateiname = .Cells(ZeileListe, 1)
'Quelle schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open(Filename:=sDateiname, ReadOnly:=True)
For Each wksQuelle In wbQuelle.Worksheets
ZeileZ = ZeileZ + 1
wksZiel.Cells(ZeileZ, 1).Value = wbQuelle.Name 'oder =wbQuelle.FullName
wksZiel.Cells(ZeileZ, 2).Value = wksQuelle.Name 'Tabellenname
'Begriffe in Quelle suchen und Werte eintragen
wksZiel.Cells(ZeileZ, 3).Value = fncSuchen(vSuchen:="Datum", wks:=wksQuelle)
wksZiel.Cells(ZeileZ, 4).Value = fncSuchen(vSuchen:="Name", wks:=wksQuelle)
wksZiel.Cells(ZeileZ, 5).Value = fncSuchen(vSuchen:="Faktor", wks:=wksQuelle)
'usw.
Next
'Quelle wieder schliessen
wbQuelle.Close savechanges:=False
Next
End With
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Fertig"
End Sub
Function fncSuchen(vSuchen, wks As Worksheet, _
Optional ByVal lOffsetZeile As Long = 0, _
Optional ByVal lOffsetSpalte As Long = 1, _
Optional ByVal lLookat As Long = xlWhole, _
Optional ByVal lLookin As Long = xlValues) As Variant
Dim Zelle As Range
Set Zelle = wks.Cells.Find(What:=vSuchen, lookat:=lLookat, LookIn:=lLookin)
If Zelle Is Nothing Then
fncSuchen = "Not Found"
Else
fncSuchen = Zelle.Offset(lOffsetZeile, lOffsetSpalte).Value
End If
End Function