AW: Dateien aus Verzeichnis lesen
19.03.2007 10:03:54
Kai
Hallo Jürgen,
ich habe jetzt mal .SearchSubFolders = True auf true gesetzt. Es klappt immer noch nicht. Hier mal mein ganzer Code. Kannst du ihn dir mal anschauen?
Option Explicit
Sub Zusammenfassen()
Dim wbkQ As Workbook, arr As Variant, iNr As Integer
Dim datUhr As Date, iRowQ As Long, iRowZ As Long, iCol As Integer
Const strVerz = "c:\bla" ' Ordner/Verzeichnis mit den Quellmappen
Const boolInf = False ' False, wenn Dateiname+Datum nicht in die Liste sollen
Const vBlatt = 1 ' "Tabelle1" ' Blattnummer oder Blattname in den Quellmappen
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
arr = FileArray(strVerz, "*.xls")
For iNr = 1 To UBound(arr)
If arr(iNr) ThisWorkbook.Name Then
datUhr = Now
Set wbkQ = Workbooks.Open(strVerz & "\" & arr(iNr), 0)
With wbkQ.Worksheets(vBlatt)
iRowQ = .Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Activate
If iNr = 1 Then
If IsEmpty(Cells(1, 1)) Then
.Rows(1).Copy
Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Cells(1, 1).Select
ActiveWindow.FreezePanes = True
End If
If boolInf Then
iCol = Cells(1, Columns.Count).End(xlToLeft).Column
If Cells(1, iCol - 1) & Cells(1, iCol) = "Quelldateiam" Then
iCol = iCol - 1
Else
iCol = iCol + 1
Range(Cells(1, iCol), Cells(1, iCol + 1)) = Split("Quelldatei am")
End If
End If
End If
If iRowQ > 1 Then
iRowZ = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range(.Rows(2), .Rows(iRowQ)).Copy
Cells(iRowZ, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Application.CutCopyMode = False
If boolInf Then
Range(Cells(iRowZ, iCol), Cells(iRowZ + iRowQ - 2, iCol)) = wbkQ.Name
Range(Cells(iRowZ, iCol + 1), Cells(iRowZ + iRowQ - 2, iCol + 1)) = datUhr
End If
End If
End With
wbkQ.Close savechanges:=False
End If
Next iNr
If UBound(arr) > -1 Then
Rows(1).HorizontalAlignment = xlHAlignCenter
If boolInf Then Columns(iCol + 1).NumberFormat = "dd.mm.yyyy hh:mm:ss"
ActiveSheet.UsedRange.Columns.AutoFit
iRowZ = iRowZ + iRowQ - 1
Application.Goto Cells(IIf(iRowZ > 25, iRowZ - 25, 1), 1), True
Cells(iRowZ, 1).Select
End If
ERRORHANDLER:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function FileArray(ByVal strPath As String, sPattern As String)
Dim arr(), iNr As Integer, tmp As String
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = True
.Filename = sPattern
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
ReDim arr(1 To .FoundFiles.Count)
For iNr = 1 To .FoundFiles.Count
tmp = .FoundFiles(iNr)
arr(iNr) = Right(tmp, Len(tmp) - InStrRev(tmp, "\"))
Next iNr
Else
ReDim arr(-1 To -1)
MsgBox "Es wurden keine Dateien gefunden.", vbInformation
End If
End With
FileArray = arr
End Function