Herbers Excel-Forum - das Archiv

Daten aus verschiedenen Arb.Mappen in eine Tabelle

Bild

Betrifft: Daten aus verschiedenen Arb.Mappen in eine Tabelle
von: Sören

Geschrieben am: 04.01.2007 22:42:38
Hallo an alle hier im Forum,
ich habe vor 14 Tagen diese Frage gestellt und Fritz war so nett und hat mir geholfen. Leider kam ich erst heute wieder dazu die Dateien zu bearbeiten und es erscheint beim Ausführen des Scripts die Fehlermeldung "Fehler beim Kompilieren / Erwartet: Sup oder Function" Was bedeutet dies?
Vielen Dank für eure Hilfe
Sören
Betrifft: Daten aus verschiedenen Arb.Mappen in eine Tabelle
von: Sören

Geschrieben am: 18.12.2006 10:39:19
Hallo an alle im Forum,
ich benötige mal wieder eure Hilfe.
Und zwar habe ich einen Ordner mit verschiedenen Arbeitsmappen. (Jede Arbeitsmappe besteht aus 3 Tabellenblättern, wobei nur das erste jeweils benutzt wird.) Dieses Tabellenblatt ist eine Rechnung und in den Zellen B1 - B7 stehen die Adressdaten. Jetzt muss ich die einzelnen Adressen in einer neuen Tabelle zusammenfassen. Kennt jemand dafür einen Makro?
Vielen Dank
Sören
Betrifft: AW: Daten aus verschiedenen Arb.Mappen in eine Tabelle
von: Fritz Hellbach

Geschrieben am: 18.12.2006 12:53:04
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

Bild

Betrifft: AW: Daten aus verschiedenen Arb.Mappen in eine Tab
von: Erich G.

Geschrieben am: 05.01.2007 00:08:50
Hallo Sören,
das liegt vermutlich daran, dass am Beginn des Codes durch die automatische Darstellung hier im Forum
ein paar Zeilen "zerrissen" sind. Das Declare gehört immer - getrennt durch ein Leerzeichen - direkt vor das folgende Wort.
Der Anfang des Codes sieht dann so aus:
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
usw.
Rückmeldung wäre nett! - Erich aus Kamp-Lintfort wünscht allen einen guten Start ins neue Jahr!
Bild

Betrifft: AW: Daten aus verschiedenen Arb.Mappen in eine Tab
von: Sören

Geschrieben am: 05.01.2007 11:19:05
Hallo Erich, vielen Dank für deinen Hinweis. Ich habe es geändert und jetzt bleibt das Script hier hängen: PathName & ClearFileName)
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 = "H:\Anna\Check-out\2007\Januar\" '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) << das ist markiert und es erscheint die Fehlermeldung: Fehler beim Kompilieren: Sub oder Funktion nicht definiert.
(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
Kanst du mir sagen, was ich noch ändern muß?
Vielen Dank
Sören
Bild

Betrifft: AW: Daten aus verschiedenen Arb.Mappen in eine Tab
von: Erich G.

Geschrieben am: 05.01.2007 14:18:40
Hallo Sören,
da hast du den Code wohl etwas geändert...
(FD.cFileName) gehört direkt hinter ClearFileName
Sieht dann so aus:
    FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Bild

Betrifft: AW: Daten aus verschiedenen Arb.Mappen in eine Tab
von: Sören

Geschrieben am: 05.01.2007 17:03:33
Hallo Erwin, in dem Beispiel ist es nur wegen mir auseinander gerutscht - ansonsten ist es hintereinander geschrieben, aber eben mit dieser Fehlermeldung.
Was kann es sonst sein?
Viele Grüße
Sören
Hier noch einmal das ganze Script:
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 = "H:\Anna\Check-out\2007\Januar\"       '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

Bild

Betrifft: AW: Daten aus mehreren Mappen
von: Erich G.

Geschrieben am: 05.01.2007 17:51:02
Hallo Sören,
jetzt habe ich das Makro selbst getestet und kann keinen Fehler finden.
Nach deiner Fehlermeldung scheint es bei dir die Funktion ClearFileName() nicht zu geben.
Sie steht aber unterhalb der Prozedur xx.
Versuch bitte mal, das Projekt zu kompilieren, nachdem du die Fehlerzeile
FoundFileNames(UBound(FoundFileNames)) = PathName & ClearFileName(FD.cFileName)
gekürzt hast hast zu
FoundFileNames(UBound(FoundFileNames)) = PathName
(Kompilieren geht im VBA-Editor-Menü mit Debuggen - Kompilieren von ...)
Gibt es eine Fehlermeldung?
Aber bitte das Makro so NICHT starten - das gäbe andere Fehler.
Rückmeldung wäre nett! - Grüße von Erich [nicht: ERWIN] aus Kamp-Lintfort
Bild

Betrifft: AW: Daten aus mehreren Mappen
von: Sören
Geschrieben am: 05.01.2007 19:54:15
Hallo Erwin, mit der gekürzen Zeile gehts, aber in der 9. Zeile von unten:
End SubFunction ClearFileName(CDat)
kommt eine neue Fehlermeldung "Syntaxfahler"
Was ist das nun wieder?
Vielen Dank
Sören
Bild

Betrifft: AW: Daten aus mehreren Mappen
von: Erich G.

Geschrieben am: 05.01.2007 23:16:21
Hallo Sören,
zunächst mal:
Ich hab doch geschrieben: "Grüße von Erich [nicht: ERWIN] aus Kamp-Lintfort"
Ich bin also der Erich, nicht der Erwin... ;-))
Wie ist denn End SubFunction ClearFileName(CDat) in eine Zeile zusammengerutscht?
Kein Wunder, dass VBA die Funktion ClearFileName nicht kennt...
Füg da mal mindestens eine, besser 2 Absatzmarken ein - dann wird daraus
End Sub
Function ClearFileName(CDat)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Bild

Betrifft: AW: Daten aus mehreren Mappen
von: Sören

Geschrieben am: 06.01.2007 11:52:38
Hallo Erich, bitte entschuldige den falschen Namen, aber ich war sicher so in das Problem vertieft, das ich ihn falsch geschrieben habe. Also nochmals sorry und vielen Dank für deine Hilfe. Es funktioniert jetzt alles.
Eine Sache würde ich gern noch mit einbauen. Denn den Pfad er Dateien muß ich im Makro ändern. Geht es, dass ich in meinem Tabellenblatt (von dem aus ich das Makro starte) in die Zelle B1 den Pfad eintrage bzw. ändere und das Makro sich die Angaben von dort holt?
Das Makro ist wirklich sehr hilfreich für mich, vielen Dank.
Sören
Bild

Betrifft: AW: Daten aus mehreren Mappen
von: Erich G.

Geschrieben am: 07.01.2007 22:40:49
Hallo Sören,
dazu brauchst du vermutlich (ungetestet) nur eine Zeile oben in xx zu ändern, von
PathName = "D:\temp\herber\"        'Pfadname der Excel-Dateien
in
PathName = Cells(1, 2)         'Pfadname der Excel-Dateien
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Bild

Betrifft: AW: Daten aus mehreren Mappen
von: Sören

Geschrieben am: 08.01.2007 11:11:21
Hallo Erich, es funktioniert.
Vielen Dank und viele Grüße
Sören
 Bild
Excel-Beispiele zum Thema "Daten aus verschiedenen Arb.Mappen in eine Tabelle"
Verstreute Daten in verschiedenen Tabellen zusammenfassen CommandButtons in verschiedenen Tabellen mit einem Makro
Synchronisieren von Optionsfeldern in verschiedenen Blättern Anzahl von Werten nach verschiedenen Bedingungen.
Aus verschiedenen Zellwerten zusammengesetzte Webadresse aufrufen Wert aus Optionsfelder in verschiedenen Frames auslesen
Darstellung der verschiedenen Erscheinungsformen von LixtBoxes Suche über mehrere Tabellen
Benennen von Tabellenblättern mit Monatsnamen Druckseitenlinien im Tabellenblatt