AW: Bestimmte Werte aus vielen Dateien zusammenfas
05.01.2009 15:19:30
Tino
Hallo,
teste mal diese Version.
Option Explicit
Dim Liste() As String, iCount As Integer
Sub SucheDatei()
Dim Fso, ordner, varDatei
Dim SucheDatei As String, DateiName As String, strPfad As String
Dim strFormel As String
Dim lngRow As Long, A As Long
Dim i As Integer
SucheDatei = ".xls" 'Filter für Dateisuche, hier nur *.xls Dateien
lngRow = 2 'erste Einfügezeile
strPfad = "J:\1 Forum" 'Pfad angeben, wo die Unterordner enthalten sind
'Auch dieser Ordner kann Dateien enthalten
Redim Preserve Liste(iCount)
Liste(iCount) = strPfad
iCount = iCount + 1
Listordner (strPfad)
Set Fso = CreateObject("Scripting.FileSystemObject")
For i = Lbound(Liste) To Ubound(Liste)
Set ordner = Fso.getfolder(Liste(i))
For Each varDatei In ordner.Files
If varDatei Like "*" & SucheDatei & "*" Then
DateiName = Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\"))
DateiName = "'" & Replace(varDatei, DateiName, "[" & DateiName & "]2008'!")
'BCD3 der Name, BCD4 Vorname, B-I5 der Ort**********************
For A = 1 To 3
strFormel = DateiName & Cells(2 + A, 2).Address(, , xlR1C1)
Cells(lngRow, A) = ExecuteExcel4Macro(strFormel)
Next A
'Wert I6********************************************************
strFormel = DateiName & Range("I6").Address(, , xlR1C1)
Cells(lngRow, 4) = ExecuteExcel4Macro(strFormel)
'Werte aus B10, C10, D10 und E10********************************
For A = 1 To 4
strFormel = DateiName & Cells(10, 1 + A).Address(, , xlR1C1)
Cells(lngRow, 4 + A) = ExecuteExcel4Macro(strFormel)
Next A
lngRow = lngRow + 1
End If
Next varDatei
Next i
Erase Liste: iCount = 0
End Sub
Sub Listordner(sPfad As String)
Dim Fso, ordner, UnterOrdner
Set Fso = CreateObject("Scripting.FileSystemObject")
Set ordner = Fso.getfolder(sPfad)
For Each UnterOrdner In ordner.subfolders
Redim Preserve Liste(iCount)
Liste(iCount) = UnterOrdner.Path
iCount = iCount + 1
Listordner (UnterOrdner)
Next
End Sub
Gruß Tino