Listen aus vielen Unterverzeichnissen zusammenführ

Sub Zusammenfassen_FS() Dim FileArray() As Variant Dim FileName As Variant Dim FileCount As Integer FileCount = 0 FileName = Dir("R:\Products\Portfolio 2016\Products per Store\*FS*_PortfolioManagement.xlsm" _ _ ) If FileName = "" Then GoTo NoFilesFound ActiveWorkbook.Windows(1).Caption = "Overview" Do While FileCount 1 Then Range("A65536").End(xlUp).Offset(1, 0).Select Else Range("A2").Select End If ActiveSheet.Paste Application.CutCopyMode = False 'ActiveWorkbook.Close savechanges:=False Windows("ABC").Close savechanges:=False FileList = FileArray FileName = Dir() Loop ' Datei mit dem aktuellen Datum im Dateinamen abspeichern ActiveWorkbook.SaveAs FileName:= _ "R:\Products\Portfolio 2016\Products per Store\" & "Summary_FS_" & Format(Date$, "YYYY- _ _ MM-DD") & ".xlsm" _ , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False Range("A1").Select NoFilesFound: FileList = False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Function DateinImPfad(pfad$, Optional modus As Long = 0) As Variant Dim aFile As Variant, sFile$, uba&, aAus() As Variant, i& If Dir(pfad) = "" Or Not (modus = 0 Or modus = 1) Then DateinImPfad = "Pfad ist leer oder Modus nicht 0 oder 1" Exit Function End If sFile = CreateObject("wscript.shell").exec("cmd /c Dir " & _ Chr(34) & pfad & Chr(34) & " /b /s").stdout.readall ' chr(34)=", in "" wegen möglicher Leerzeichen im Pfad/Dateinamen aFile = Filter(Split(sFile, vbCrLf), ".") ' d.h. die Meldung "Datei nicht gefunden" fliegt raus, weil ohne "." uba = UBound(aFile) ' -1, falls leer If uba

Sub DateienÖffnen() Dim Ordner Dim Datei As String Dim od As Long Dim wb As Workbook ReDim Ordner(0) As String '--- Startverzeichnis festlegen Ordner(0) = "R:\Products\Portfolio 2016\Products per Store\" od = 0 Do While od "" If Left(Datei, 1) "." Then '--- Standard-Ordner "." und ".." ignorieren If (GetAttr(Ordner(od) & Datei) And vbDirectory) = vbDirectory Then ReDim Preserve Ordner(UBound(Ordner) + 1) Ordner(UBound(Ordner)) = Ordner(od) & Datei & "\" ElseIf Datei Like "*FS*_PortfolioManagement.xlsm" Then Set wb = Workbooks.Open(Ordner(od) & Datei) '... hier der Code zum Übertragen der Daten wb.Close False End If End If Datei = Dir Loop od = od + 1 Loop End Sub

Hi Daniel
Danke vielmals für deinen Vorschlag. Der ist super und funktioniert fast perfekt ;-).
Wahrscheinlich braucht es nur noch eine kleine Änderung, aber ich sehe es nicht mehr... Das Problem ist nun noch, dass es alle Daten in die Liste einfügt, die als Erstes geöffnet wird. Eigentlich sollten die Daten aber in das Workbook eingefügt werden, wo das Makro ausgeführt ist.
Zum Verständnis: Die Datei, in der das Makro ausgeführt wird, sollte "Overview" benannt und die Dateien aus den Unterverzeichnissen jeweils "ABC".
Hier das vollständige Makro:


Sub DateienZusammenführen()
Dim Ordner
Dim Datei As String
Dim od As Long
Dim wb As Workbook
ReDim Ordner(0) As String
'--- Startverzeichnis festlegen
Ordner(0) = "R:\Products\Portfolio 2016\Products per Store\"
od = 0
Do While od  ""
If Left(Datei, 1)  "." Then '--- Standard-Ordner "." und ".." ignorieren
If (GetAttr(Ordner(od) & Datei) And vbDirectory) = vbDirectory Then
ReDim Preserve Ordner(UBound(Ordner) + 1)
Ordner(UBound(Ordner)) = Ordner(od) & Datei & "\"
ElseIf Datei Like "*FS*_PortfolioManagement.xlsm" Then
Set wb = Workbooks.Open(Ordner(od) & Datei)
'Code zum Übertragen der Daten
Dim FileArray() As Variant
Dim FileName As Variant
Dim FileCount As Integer
FileCount = 0
FileName = Dir("R:\Products\Portfolio 2016\Products per Store\")
If FileName = "" Then GoTo NoFilesFound
ActiveWorkbook.Windows(1).Caption = "Overview"
Do While FileCount  1 Then
Range("A65536").End(xlUp).Offset(1, 0).Select
Else
Range("A2").Select
End If
ActiveSheet.Paste
Application.CutCopyMode = False
Windows("ABC").Close savechanges:=False
FileList = FileArray
FileName = Dir()
Loop
' Datei mit dem aktuellen Datum im Dateinamen abspeichern
ActiveWorkbook.SaveAs FileName:= _
"R:\Products\Portfolio 2016\Products per Store\" & "Summary_FS_" & Format(Date$, " _
YYYY-MM-DD") & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Range("A1").Select
NoFilesFound:
FileList = False
wb.Close False
End If
End If
Datei = Dir
Loop
od = od + 1
Loop
End Sub

Liebe Grüsse
Elena

Hi
nach dem Öffnen einer Datei (Workbooks.Open) ist immer die neu geöffnete Datei die aktive.
dh die neu geöffnete Datei kannst du immer über ActiveWorkbook ansprechen.
die Datei mit dem Makro kannst du immer mit ThisWorkbook ansprechen.
das mit dem Select und Activate solltest du dir abgewöhnen und die Zellen immer vollständig referenzieren.
also im Prinzip etwa so, um die Daten von der genöffneten Datei in die Datei mit dem Makro zu kopieren:

Workbooks.Open "neue Datei"
ActiveWorkbook.Worksheets(1).Usedrange.Copy
ThisWorkbook.Worksheets(1).Cells(Rows.count, 1).End(xlup).Offset(1, 0).PasteSpecial xlpasteall

hierzu auch mal das lesen
http://www.online-excel.de/excel/singsel_vba.php?f=78
Gruß Daniel

Sub DateienÖffnen() Dim Ordner Dim Datei As String Dim od As Long Dim wb As Workbook ReDim Ordner(0) As String '--- Startverzeichnis festlegen Ordner(0) = "\\example.com\projects\PortfolioManagementProcess\2016\Products_per_Store\ _ Attachments\" od = 0 Do While od "" If Left(Datei, 1) "." Then '--- Standard-Ordner "." und ".." ignorieren If (GetAttr(Ordner(od) & Datei) And vbDirectory) = vbDirectory Then ReDim Preserve Ordner(UBound(Ordner) + 1) Ordner(UBound(Ordner)) = Ordner(od) & Datei & "\" ElseIf Datei Like "*FS*_PortfolioManagement.xlsm" Then Set wb = Workbooks.Open(Ordner(od) & Datei) 'Code zum Übertragen der Daten Dim FileArray() As Variant Dim FileName As Variant Dim FileCount As Integer FileCount = 0 FileName = Dir("\\example.com\projects\PortfolioManagementProcess\2016\ _ Products_per_Store\Attachments\") If FileName = "" Then GoTo NoFilesFound ActiveWorkbook.Windows(1).Caption = "Overview" Do While FileCount

Beliebteste Forumthreads (12 Monate)

Listen aus vielen Unterverzeichnissen zusammenführ

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread