AW: Daten aus verschiedenen Arb.Mappen in eine Tabelle
18.12.2006 12:53:04
Fritz
Hallo Sören,
vielleicht hilft dir dies weiter.
Die Pfade musst Du natürlich noch anpassen und die Datei, die Du bearbeitest, also die neue, darf nicht im gleiche Ordner stehen, wie die zu lesenden Dateien.
Gruß Fritz
Option Explicit
Declare
Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare
Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Declare
Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MAX_PATH = 260
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public 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
Public 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
Sub xx()
Dim I&, J&, LZ&
Dim FoundFileNames() As String
Dim Ws1 As Worksheet
Dim WbTmp As Workbook
Dim WsTmp As Worksheet
Dim hFind&, hFile&, nFile&
Dim FD As WIN32_FIND_DATA
Dim PathName$, Pattern$
PathName = "D:\temp\herber\" 'Pfadname der Excel-Dateien
Pattern = "*.xls" ' Dateiendung
Set Ws1 = ActiveWorkbook.ActiveSheet
LZ = Ws1.Cells.SpecialCells(xlCellTypeLastCell).Row
'Alle Excel-Dateien ermitteln
ReDim FoundFileNames(0)
hFile = FindFirstFile(PathName & Pattern, FD)
If hFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
Do
nFile = FindNextFile(hFile, FD)
If nFile > 0 Then
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName)
ReDim Preserve FoundFileNames(UBound(FoundFileNames) + 1)
End If
Loop While nFile <> 0
End If
FindClose hFile
'Verarbeitung starten
For I = 0 To UBound(FoundFileNames) - 1
Set WbTmp = Workbooks.Open(FoundFileNames(I))
Set WsTmp = WbTmp.Sheets(1)
For J = 1 To 7
Ws1.Cells(LZ + 1, J) = WsTmp.Cells(J, 2)
Next
Set WsTmp = Nothing
WbTmp.Close
LZ = LZ + 1
Next
End Sub
Function ClearFileName(CDat)
Dim X&
X = InStr(1, CDat, Chr$(0))
If X > 0 Then
ClearFileName = Trim$(Left$(CDat, X - 1))
Exit Function
End If
ClearFileName = ""
End Function