Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1152to1156
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Werte aus mehreren Dateien auslesen

Werte aus mehreren Dateien auslesen
Enrico
Hallo zusammen
ich habe ca. 1000 Excel Dateien jede mit ca. 10 Sheets.
Da sich im Verlauf der Erstellung der Dateien ( 2 Jahre ) die Vorlage mehrmals geändert hat sind die Namen der Sheets und auch die Position der Zellen mit den relevanten Daten nicht gleich.
Ich möchte nun für eine Historie bestimmte Werte aus jeder Datei auslesen
(Datum , Name , Faktor, ...)
Über ein Makro habe ich es schon geschafft alle Dateinamen incl Pfad in ein Tabellenblatt zu schreiben.
Nun bräuchte ich noch alle verfügbaren Tabellenblätter pro Datei.
Auf die Position der Daten in den Blättern könnte ich evtl. anhand des Sheetnamens schließen.
Noch besser wäre natürlich wenn ich nach einem bestimmten String in jedem Blatt suchen, und die Zelle rechts davon auslesen könnte.
Hat da jemand eine Idee für eine Lösung.

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Werte aus mehreren Dateien auslesen
05.05.2010 22:36:18
jowe
Hallo Enrico,
angenommen, in 'C:\Temp' liegen etliche Excel-Arbeitsmappen, weiter angenommen, in einer Arbeitsmappe z.B. 'Main.xls' sind in der Tabelle 'Dateinamen' in der Spalte 'A' ab Zeile '2' alle diese Arbeitsmappen mit dem Dateinamen (xxxxx.xls) untereinander aufgeführt. Das folgende Makro wird jede aufgeführte Arbeitsmappe öffnen und sämtliche Tabellennamen neben den Namen der Arbeitsmappe beginnend in Spalte' B' bis Spalte 'nn' der Arbeitsmappe 'Main.xls' eintragen:
Sub getheets()
Dim mySh As Worksheet
Dim i, sp As Long
Dim myPath
myPath = "C:\Temp"
Set mySh = ThisWorkbook.Sheets("Dateinamen")
sp = 1
For i = 2 To mySh.[A65536].End(xlUp).Row
Workbooks.Open Filename:=myPath & "\" & mySh.Cells(i, 1)
For Each t In ActiveWorkbook.Sheets
sp = sp + 1
mySh.Cells(i, sp) = t.Name
Next
ActiveWorkbook.Close savechanges:=False
sp = 1
Next
End Sub

Achtung! Ich habe noch keine Fehlerroutine eingebaut!
Gruß
Jochen
Anzeige
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

Anzeige

344 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige