AW: 600 Excel Mappen Zu Einer Machen
16.03.2007 10:40:00
Kai
Hallo Holger,
ich habe das hier gerade bei Herber gefunden. Es klappt aber noch nicht ganz. Und zwar wird nur der Inhalt von einer Arbeitsmappe übernommen (ich denke die erste aus dem Verzeichnis \Bla). Dann ist Schluss. Vielleicht hast du eine Idee?
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 = "Tabelle1" ' "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 = False
.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