VBA: Aus Mappen Arbeitsblätter automatisiert in einzige Tabelle aneinanderkopieren

27/08/2010 - 23:13 von Ch.Wolfram | Report spam
Excel 2007 :

Von einem bestimmten Verzeichnis (F:\LISTEN) und deren direkten
Unterverzeichnissen (maximal 30, keine Unter-Unterverzeichnisse)

sollen von allen dortigen Excel-Dateien das Arbeitsblatt "Tabelle1" in
aufsteigender Reihenfolge des Dateinamens in ein einzige neue
Arbeitsmappe in Blatt "Tabelle1", ab Spalte B:B " )aneinanderkopiert
werden. In der dortigen Spalte A:A muss
in jeder Zeile der Dateiname der jeweils dazukopierten Tabelle
eingetragen werden.
Format der jetzigen Dateinamen: JJ-MM-TT.xls

Ziel ist eine einzige Tabelle, welche alle Datensàtze aus allen
Unterverzeichnissen mit dem Dateinamen pro Datensatz enthàlt,
um Auswertungen durchzuführen.

Es wàre mir auch schon mit einem Weg über die Benutzeroberflàche
geholfen, ohne 300 Dateien einzeln abnicken zu müssen.

Ich bin absoluter VBA-Neuling. Ein funktionierender Vorschlag von
euch würde mich in vielen àhnlich gelagerten Aufgaben (z.B. Druck
von mehr als 15 Excel-Dateien gleichzeitig) sehr weiterhelfen.
Bis Office97 konnte ich diese Aufgaben mit Makros lösen.

Über Hilfe freut sich:
Christian
 

Lesen sie die antworten

#1 Andreas Killer
29/08/2010 - 17:03 | Warnen spam
Am 27.08.2010 23:13, schrieb Ch.Wolfram:

Excel 2007 :


...
Ich bin absoluter VBA-Neuling.



Dann hast Du nun ein kleineres Problem, weil das FileSearch-Objekt von Microsoft ersatzlos gestrichen wurde und die
Lösung des ganzen umfangreicher ist.

Dazu brauchen wir 2 Codeteile, ein normales Modul und ein Klassenmodul welches das FileSearch-Objekt ersetzt.

Dieser Code muss in ein normales Modul, wie's geht steht hier:
http://www.online-excel.de/excel/si....php?fD#s2

schnipp
Dim ApplicationFileSearch As New FileSearch

Sub Main()
Dim I As Long
With ApplicationFileSearch
.FileName = "*.xls"
.LookIn = "F:\LISTEN"
.SearchSubFolders = True
I = .Execute(msoSortByFileName)
If I = 0 Then
MsgBox "Keine Dateien gefunden"
Exit Sub
End If
Application.ScreenUpdating = False
For I = 1 To .FoundFiles.Count
ImportWB .FoundFiles(I)
Next
Application.ScreenUpdating = True
End With
End Sub

Private Sub ImportWB(FileName As String)
Dim WB As Workbook, Data, R As Range
'Letzte Zelle des aktiven Blattes holen
Set R = SheetLastCell
'Wenn Blatt nicht leer
If R.Address(0, 0) <> "A1" Or Not IsEmpty(R) Then
'dann nàchste Zeile Spalte 2
Set R = Cells(R.Row + 1, 2)
Else
'erste Zeile Spalte 2
Set R = Range("B1")
End If
'Dateiname in Spalte A eintragen
R.Offset(0, -1) = FileName

On Error GoTo ErrorHandler
'Datei öffnen
Set WB = Workbooks.Open(FileName, False, True)
'Daten einlesen
Data = WB.Sheets("Tabelle1").UsedRange
'Datei zu
WB.Close False
Set WB = Nothing

'Daten importieren
If IsArray(Data) Then
R.Resize(UBound(Data), UBound(Data, 2)) = Data
'Dateinamen in Spalte A eintragen
R.Offset(0, -1).Resize(UBound(Data)) = FileName
Else
R = Data
End If
Exit Sub

ErrorHandler:
'Fehler eintragen
R = "Fehler " & Err.Number
Select Case Err.Number
Case 9
R.Offset(0, 1) = "Tabelle1 nicht vorhanden"
Case Else
R.Offset(0, 1) = Err.Description
End Select
On Error Goto 0
If Not WB Is Nothing Then WB.Close False
End Sub

Private Function SheetLastCell(Optional WS As Worksheet) As Range
'Liefert die letzte gefüllte Zelle der Tabelle
Dim R As Range, C As Range
If WS Is Nothing Then Set WS = ActiveSheet
Set R = WS.Cells.SpecialCells(xlCellTypeLastCell)
If IsEmpty(R) And Not R.Address = Cells(1, 1).Address Then
Set C = WS.Cells.Find("*", After:=R, SearchOrder:= _
xlByColumns, SearchDirection:=xlPrevious)
If C Is Nothing Then
Set SheetLastCell = WS.Cells(1, 1)
Else
Set R = WS.Cells.Find("*", After:=R, SearchOrder:= _
xlByRows, SearchDirection:=xlPrevious)
Set SheetLastCell = WS.Cells(R.Row, C.Column)
End If
Else
Set SheetLastCell = R
End If
End Function
schnapp

Der angehàngte Code muss in ein Klassenmodul, wie's geht steht hier:
http://www.online-excel.de/excel/si....php?fD#s6

Wenn Du den Code eingefügt hast drückst Du F4 und benennst es von "Klasse1" in "FileSearch" um.

Danach führst Du das Makro "Main" aus.

Andreas.

'Version 1.2
'Andreas Killer
'12.10.09
'Attribute VB_Name = "FileSearch"

'Nachbildung des FileSearch-Objektes für Office 2007
'Property-Tests sind nicht implementiert!

Option Explicit

Public Enum msoSortBy
msoSortByFileName = 1
msoSortBySize = 2
msoSortByFileType = 3
msoSortByLastModified = 4
End Enum

Public Enum msoFileType
msoFileTypeAllFiles = 1
msoFileTypeOfficeFiles = 2
msoFileTypeWordDocuments = 3
msoFileTypeExcelWorkbooks = 4
msoFileTypePowerPointPresentations = 5
msoFileTypeBinders = 6
msoFileTypeDatabases = 7
msoFileTypeTemplates = 8
End Enum

Public Enum msoLastModified
msoLastModifiedYesterday = 1
msoLastModifiedToday = 2
msoLastModifiedLastWeek = 3
msoLastModifiedThisWeek = 4
msoLastModifiedLastMonth = 5
msoLastModifiedThisMonth = 6
msoLastModifiedAnyTime = 7
End Enum

Private fsFileName As Variant
Public LookIn As String
Public SearchSubFolders As Boolean
Public FoundFiles As Collection
Private fsFileType As msoFileType
Private fsLastModified As msoLastModified

Private SortFiles As Collection
Private SortFilesBy As msoSortBy
Private fs As Object 'FileSystemObject

Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private Const FIND_FIRST_EX_CASE_SENSITIVE As Long = 1
Private Const FIND_FIRST_EX_LARGE_FETCH As Long = 2

Private Enum FINDEX_SEARCH_OPS
FindExSearchNameMatch
FindExSearchLimitToDirectories
FindExSearchLimitToDevices
End Enum

Private Enum FINDEX_INFO_LEVELS
FindExInfoStandard
FindExInfoMaxInfoLevel
End Enum

Private Declare Function FindFirstFile Lib "kernel32" Alias _
"FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
As WIN32_FIND_DATA) As Long
Private Declare Function FindFirstFileEx Lib "kernel32" Alias _
"FindFirstFileExA" (ByVal lpFileName As String, ByVal _
fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _
ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal _
dwAdditionalFlags As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias _
"FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As _
WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal _
hFindFile As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal _
psString As Any) As Long

Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount _
As Long)

Private Sub Class_Initialize()
Set FoundFiles = New Collection
Set SortFiles = New Collection
Set fs = CreateObject("Scripting.FileSystemObject")
FileType = msoFileTypeOfficeFiles
LastModified = msoLastModifiedAnyTime
End Sub

Private Sub Class_Terminate()
Set FoundFiles = Nothing
Set SortFiles = Nothing
Set fs = Nothing
End Sub

Public Sub NewSearch()
FileName = ""
LookIn = ""
FileType = msoFileTypeOfficeFiles
LastModified = msoLastModifiedAnyTime
SearchSubFolders = False
ClearCollections
End Sub

Private Sub ClearCollections()
Dim I As Long
With SortFiles
For I = .Count To 1 Step -1
.Remove I
Next
End With
With FoundFiles
For I = .Count To 1 Step -1
.Remove I
Next
End With
End Sub

Property Let FileName(Value As Variant)
If IsArray(Value) Then
fsFileName = Value
Else
fsFileName = Array(Value)
End If
fsFileType = 0
End Property

Property Get FileName() As Variant
FileName = Join(fsFileName, ", ")
End Property

Property Let FileType(Value As msoFileType)
fsFileType = Value
Select Case Value
Case msoFileTypeAllFiles
fsFileName = Array("*.*")
Case msoFileTypeOfficeFiles
fsFileName = Array("*.doc", "*.dot", "*.htm", "*.html", _
"*.mdb", "*.mpd", "*.obd", "*.obt", "*.pot", "*.pps", "*.ppt", _
"*.xls", "*.xlt")
Case msoFileTypeWordDocuments
fsFileName = Array("*.doc", "*.htm", "*.html")
Case msoFileTypeExcelWorkbooks
fsFileName = Array("*.xls")
Case msoFileTypePowerPointPresentations
fsFileName = Array("*.pps", "*.ppt")
Case msoFileTypeBinders
fsFileName = Array("*.obd")
Case msoFileTypeDatabases
fsFileName = Array("*.mdb", "*.mpd")
Case msoFileTypeTemplates
fsFileName = Array("*.dot", "*.obt", "*.pot", "*.xlt")
Case Else
fsFileType = 0
fsFileName = Array("*.*")
End Select
End Property

Property Get FileType() As msoFileType
FileType = fsFileType
End Property

Property Let LastModified(Value As msoLastModified)
If Value >= 1 And Value <= 7 Then
fsLastModified = Value
Else
fsLastModified = msoLastModifiedAnyTime
End If
End Property

Property Get LastModified() As msoLastModified
LastModified = fsLastModified
End Property

Private Function MakeDecimal(ByVal Lo As Long, ByVal Hi As _
Long, Optional ByVal wEx As Long = 0, Optional Minus As _
Boolean = False) As Variant
If Minus Then MakeDecimal = CDec(-1) Else MakeDecimal = CDec(1)
CopyMemory ByVal VarPtr(MakeDecimal) + 8, Lo, 4
CopyMemory ByVal VarPtr(MakeDecimal) + 12, Hi, 4
If wEx <> 0 Then CopyMemory ByVal VarPtr(MakeDecimal) + 4, _
Lo, 4
End Function

Private Function FirstWeek(ByVal Datum As Date) As Date
'Liefert den 1. Tag der Woche in dem Datum liegt
FirstWeek = Datum - Weekday(Datum, vbUseSystemDayOfWeek) + 1
End Function

Private Sub SearchPrim(ByVal Path As String)
Dim hFindFile As Long, hFoundFile As WIN32_FIND_DATA
Dim FName As String, STime As SYSTEMTIME, FTime As Date, _
ETime As Date, LTime As Date
Dim I As Integer, AddIt As Boolean

If fsLastModified <> msoLastModifiedAnyTime Then
Select Case fsLastModified
Case msoLastModifiedYesterday
ETime = Date - 1
LTime = Date - 1
Case msoLastModifiedToday
ETime = Date
LTime = Date
Case msoLastModifiedLastWeek
ETime = FirstWeek(Date) - 7
LTime = ETime + 6
Case msoLastModifiedThisWeek
ETime = FirstWeek(Date)
LTime = ETime + 6
Case msoLastModifiedLastMonth
ETime = DateSerial(Year(Date), Month(Date) - 1, 1)
LTime = DateSerial(Year(Date), Month(Date), 0)
Case msoLastModifiedThisMonth
ETime = DateSerial(Year(Date), Month(Date), 1)
LTime = DateSerial(Year(Date), Month(Date) + 1, 0)
End Select
End If

'Sicherstelen das ein Backslash dran ist
If Right(Path, 1) <> "\" Then Path = Path & "\"
'Suche nach den Dateien
For I = LBound(fsFileName) To UBound(fsFileName)
'hFindFile = FindFirstFile(Path & fsFileName(I) & Chr(0), _
hFoundFile)
hFindFile = FindFirstFileEx(Path & fsFileName(I) & Chr(0), _
FindExInfoStandard&, hFoundFile, FindExSearchNameMatch&, 0&, 0&)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
With hFoundFile
'Die Verzeichnisse ausschließen
If Not (.dwFileAttributes And vbDirectory) = _
vbDirectory Then
If fsLastModified = msoLastModifiedAnyTime Then
AddIt = True
Else
'Konvertiere Dateizeit zu Systemzeit
FileTimeToSystemTime .ftLastWriteTime, STime
'Generiere VBA-Datum
With STime
FTime = DateSerial(.wYear, .wMonth, .wDay)
End With
AddIt = FTime >= ETime And FTime <= LTime
End If

If AddIt Then
FName = Mid$(.cFileName, 1, lstrlenA(.cFileName))
'Problem *.htm findet auch *.html
AddIt = FName Like fsFileName(I)
End If

If AddIt Then
FoundFiles.Add Path & FName

'Sollen wir sortieren?
Select Case SortFilesBy
Case msoSortByFileName
'Pfad, dann Name
SortFiles.Add FName & Path
Case msoSortByFileType
'Extension, dann Pfad, dann Name
SortFiles.Add fs.GetExtensionName(FName) & _
Path & FName
Case msoSortByLastModified
'Konvertiere Dateizeit zu Systemzeit
FileTimeToSystemTime .ftLastWriteTime, STime
'Generiere VBA-Datum
With STime
FTime = DateSerial(.wYear, .wMonth, .wDay) _
+ TimeSerial(.wHour, .wMinute, .wSecond)
End With
SortFiles.Add FTime
Case msoSortBySize
SortFiles.Add MakeDecimal(.nFileSizeLow, _
.nFileSizeHigh)
End Select
End If
End If
End With
Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
FindClose hFindFile
End If
Next

If SearchSubFolders Then
'Suche nach einem Verzeichnis
'hFindFile = FindFirstFile(Path & "*." & Chr(0), hFoundFile)
'hFindFile = FindFirstFileEx(Path & "*." & Chr(0), _
FindExInfoStandard&, hFoundFile, _
FindExSearchLimitToDirectories&, 0&, FIND_FIRST_EX_LARGE_FETCH)
hFindFile = FindFirstFileEx(Path & "*." & Chr(0), _
FindExInfoStandard&, hFoundFile, _
FindExSearchLimitToDirectories&, 0&, 0&)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
With hFoundFile
'Die Verzeichnisse "." und ".." ausschließen
If Left$(.cFileName, 1) <> "." And ( _
.dwFileAttributes And vbDirectory) = vbDirectory Then
FName = Mid$(.cFileName, 1, lstrlenA(.cFileName))
'Starte rekursive Suche
SearchPrim Path & FName
End If
End With
Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
FindClose hFindFile
End If
End If
End Sub

Private Sub QuickSortCollection(ByRef Liste As Collection, _
ByRef Data As Collection, Optional Start, Optional Ende, _
Optional Compare As vbCompareMethod = vbDatabaseCompare, _
Optional SortOrder As MsoSortOrder = msoSortOrderAscending)
'Sortiert eine Collection mit beliebigen Werten im Bereich _
Start..Ende, führt die Data-Collection parallel mit
'vbDatabaseCompare sortiert Zahlen, ansonsten werden Texte _
sortiert
Dim I As Long, J As Long, C As Integer, Pivot As Variant

If Liste.Count <= 1 Then Exit Sub
If IsMissing(Start) Then Start = 1
If IsMissing(Ende) Then Ende = Liste.Count
If SortOrder = msoSortOrderAscending Then C = 1 Else C = -1

I = Start: J = Ende
Pivot = Liste((Start + Ende) \ 2)
Do
If Compare = vbDatabaseCompare Then
'Zahlen sortieren
If SortOrder = msoSortOrderAscending Then
While (Liste(I) < Pivot): I = I + 1: Wend
While (Liste(J) > Pivot): J = J - 1: Wend
Else
While (Liste(I) > Pivot): I = I + 1: Wend
While (Liste(J) < Pivot): J = J - 1: Wend
End If
Else
'Texte sortieren
Do While (StrComp(Liste(I), Pivot, Compare) = -C): I = I _
+ 1: Loop
Do While (StrComp(Liste(J), Pivot, Compare) = C): J = J - _
1: Loop
End If
If (I <= J) Then
If I < J Then
Liste.Add Liste(I), After:=J
Liste.Add Liste(J), After:=I
Liste.Remove I
Liste.Remove J
Data.Add Data(I), After:=J
Data.Add Data(J), After:=I
Data.Remove I
Data.Remove J
End If
I = I + 1: J = J - 1
End If
Loop Until (I > J)
If (Start < J) Then QuickSortCollection Liste, Data, Start, _
J, Compare, SortOrder
If (I < Ende) Then QuickSortCollection Liste, Data, I, Ende, _
Compare, SortOrder
End Sub

Public Function Execute(Optional SortBy As msoSortBy = 0, _
Optional SortOrder As MsoSortOrder = msoSortOrderAscending, _
Optional AlwaysAccurate As Boolean = True) As Long
Dim I As Long
'Beginnt die Suche nach den angegebenen Dateien.
'SortBy:
' Die für die Sortierung der zurückgegebenen Dateien _
verwendete Methode. Dies kann eine der folgenden MsoSortBy- _
Konstanten sein: msoSortbyFileName, msoSortbyFileType, _
msoSortbyLastModified oder msoSortbySize. Ist SortBy = 0 wird _
nicht sortiert
'SortOrder:
' Die Reihenfolge, in der die zurückgegebenen Dateien _
sortiert werden sollen. Dies kann eine der folgenden _
MsoSortOrder-Konstanten sein: msoSortOrderAscending oder _
msoSortOrderDescending.
'AlwaysAccurate:
' Ohne Funktion, nur aus Kompatiblitàtsgründen

ClearCollections
SortFilesBy = SortBy
SearchPrim LookIn
Execute = FoundFiles.Count
Select Case SortBy
Case msoSortByFileName, msoSortByFileType
QuickSortCollection SortFiles, FoundFiles, Compare:= _
vbTextCompare, SortOrder:=SortOrder
Case msoSortByLastModified, msoSortBySize
QuickSortCollection SortFiles, FoundFiles, Compare:= _
vbDatabaseCompare, SortOrder:=SortOrder
End Select
End Function

Ähnliche fragen