Unterordner bei Datei auslesen einbeziehen
11.01.2016 18:08:33
Vicky
ich habe ein Makro, welches Daten aus unterschiedlichen (gleich aufgebauten) Dateien auslesen soll.
Bsp. aus Reiter 1 werden die Zellen A1 und B5 ausgelesen, aus Reiter 2 C7 usw.
Das alles wird dann in eine Gesamtliste geschrieben, in der jede Zeile 1 Datei entspricht.
Hierbei werden aktuell immer nur die Dateien in einem bestimmten Ordner ausgelesen. Jetzt möchte ich das Makro gerne so anpassen, dass alle Dateien die in Unterordnern dieses Ordners liegen ebenfalls ausgelesen werden.
Ich habe auch schon im Internet gesucht, aber nichts gefunden, was mir weiter geholfen hat. Wisst ihr hier eine Lösung?
Aktuell ist das Makro so:
Option Explicit
Sub ExcelDateienAuswerten()
Application.ScreenUpdating = False
Dim strDateiname As String
Dim strPfad As String
Dim lngZeile As Long
'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xls) liegen
strPfad = "S:\Dateipfad\"
'Den 1. Dateinamen holen
strDateiname = Dir(strPfad & "*.xls")
'Startzeile festlegen
lngZeile = 2
'Solange ein Dateiname gelesen wird
Do While Not strDateiname = ""
'Datei verarbeiten
Call TabVerarb(strPfad & strDateiname, lngZeile)
'nächsten Dateinamen holen
strDateiname = Dir()
'Zeilenzähler erhöhen
lngZeile = lngZeile + 1
Loop
End Sub
Sub TabVerarb(strPfad As String, lngZeile As Long)
Dim strMeSH As String
Dim strDatei As String
Dim strSH As String
'Dateinamen extrahieren
strDatei = Split(strPfad, "\")(UBound(Split(strPfad, "\")))
'Eigenen Namen merken
strMeSH = ActiveWorkbook.Name
'Datei öffnen
Workbooks.Open Filename:=strPfad, Password:="passwort"
If Worksheets("4. Reiter").Range("J7") Like "Außertarifliches GG:" Then
With Workbooks(strMeSH)
'Dateinamen und auszuwertenden Zellen übertragen, sind tatsächlich ca. 30 Felder, die _
ausgelesen werden
.Sheets("ID").Cells(lngZeile, 1) = strDatei
.Sheets("ID").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("4. Reiter").Range("F6"). _
Value
.Sheets("ID").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("4. Reiter").Range("D6"). _
Value
.Sheets("ID").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("4. Reiter").Range("D7"). _
Value End With
Else
With Workbooks(strMeSH)
'Dateinamen und auszuwertenden Zellen übertragen, sind tatsächlich ca. 30 Felder, die _
ausgelesen werden
.Sheets("ID").Cells(lngZeile, 1) = strDatei
.Sheets("ID").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("4. Reiter").Range("F6"). _
Value
.Sheets("ID").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("4. Reiter").Range("D6"). _
Value
.Sheets("ID").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("4. Reiter").Range("D7"). _
Value
End With
End If
'Quelldatei schließen
Workbooks(strDatei).Saved = True
Workbooks(strDatei).Close
End Sub
Viele Grüße
Vicky