Office: Exel Dateien (aus Unterordnern) zusammenfassen

Hallo zusammen,

ich muss folgendes Problem lösen und hoffe, ihr könnt helfen! :-)

Wir haben auf dem Share mehrere Ordner und Unterordner u.a:

Ordner 1
Unterordner 1
Unterordner 2
Ordner 2
Unterordner 1

Nun sind in Ordner 2 viele Unterordner - für jeden Kunden eine und darin weitere Unterordner, zB Aktuelles, Umsatz usw.

Nun soll eine Excel-Datei in Ordner 1 auf alle Excel-Dateien in Ordner 2 zugreifen, die "Arbeit" heissen und die inhalte zusammenfassen.
Bisher werden aber nicht die Unterordner von 2 durchsucht, sondern nur 2 selbst. (Da wurde mal etwas geändert vor Jahren und seitdem funktioniert das nichtmehr). Mit neueren ideen wird aber auch nur der Hauptordner durchsucht, nicht die Unterordner?

Hat da jemand eine Idee - ich wäre sehr dankbar!


Hier mal die Makro:


Sub FilesListen()
On Error GoTo err
Call EventsOff
Dim Dateien As Integer
Dim DateiName As String
Dim zaehler As Boolean

Dim fs, Pfad As Object, Datei As Object, msgtext As String, x As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.folderexists("\\PFAD\") Then
MsgBox "Verzeichnis nicht gefunden", vbCritical, "Fehler"
Exit Sub
Else
Set Pfad = fs.GetFolder("\\PFAD\")
With Pfad
x = 0
For Each Datei In .Files
If Datei.Name Like "Arbeit*.xl*" Then
DateiName = Datei.Name
msgtext = msgtext & Chr$(13) & Chr$(10) & DateiName
x = x + 1
End If
Next
If x > 0 Then
If MsgBox("Es wurden " & x & " Dateien gefunden:" & msgtext, vbOKCancel, "Suche erfolgreich") = vbCancel Then
Exit Sub
End If
Else
MsgBox "Es wurden keine Dateien gefunden.", vbCritical, "Suche fehlgeschlagen"
Exit Sub
End If

For Each Datei In .Files
If Datei.Name Like "Arbeit*.xl*" Then
DateiName = Datei.Name
Debug.Print DateiName
'Datei verarbeiten
' If .Execute() > 0 Then
' For Dateien = 1 To .FoundFiles.Count
' DateiName = Dir(.FoundFiles(Dateien))
If DateiName ThisWorkbook.Name Then
Workbooks.Open Filename:="\\PFAD\" & DateiName
If zaehler = False Then
zeile = 4
Else
zeile = ThisWorkbook.Sheets("Arbeit").Cells(Rows.Count, 2).End(xlUp).Row + 1
End If
Debug.Print zeile
Workbooks(DateiName).Sheets("Arbeit").Range("B4:L4" & zeile).Copy
SkipBlanks = False
Transpose = False
ThisWorkbook.Sheets("Arbeit").Range("B" & zeile).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
zaehler = True
Workbooks(DateiName).Close SaveChanges:=True
End If
' Next Dateien
' End If
'Datei verarbeiten
End If
Next
End With


End If
Call EventsOn
Exit Sub


With Application.FileSearch
.NewSearch
.LookIn = "\\PFAD\"
.SearchSubFolders = True
.Filename = "Arbeit*.xl*"
If .Execute() > 0 Then
For Dateien = 1 To .FoundFiles.Count
DateiName = Dir(.FoundFiles(Dateien))
If DateiName ThisWorkbook.Name Then
Workbooks.Open Filename:=.FoundFiles(Dateien)
If zaehler = False Then
zeile = 4
Else
zeile = ThisWorkbook.Sheets("Arbeit").Cells(Rows.Count, 2).End(xlUp).Row + 1
End If
Workbooks(DateiName).Sheets("Arbeit").Range("B4:L4" & zeile).Copy
SkipBlanks = False
Transpose = False
ThisWorkbook.Sheets("Arbeit").Range("B" & zeile).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
zaehler = True
Workbooks(DateiName).Close SaveChanges:=True
End If
Next Dateien
End If
End With
Call EventsOn
Exit Sub
err:
MsgBox err.Description
Exit Sub
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

:)

 

Application.FileSearch gibt es seit XL2007 nicht mehr!!!

Welche Version benutzt ihr?

 

Hallo, danke für die Reaktion.

es ist Excel 2010.
Ja das weiß ich, dass diese Funktion nicht mehr geht, ich scheitere aber am Ersatz... Es ist egal wie ich es versuche, es wird nur der Hauptordner durchsucht...

 

Bette deinen Code in Code-Tags ein.

Code-text markieren und auf Button (Code einfügen) klicken!

 

Code:

 

Kommst du hiermit klar:

Alternative zum Filesearch

 

hier mal mein aktueller Versuch und die Probleme damit:

- Unterordner werden nicht durchsucht
- es wird ein neues Tabellenblatt geöffnet, im Idealfall soll das Ergebnis
aber im Tabellenblatt mit dem Button ab Zeile 4 und Spalte B eingefügt werden
(Formatierung von diesem Blatt (Farben, Spaltenbreiten) sollten behalten
werden.

Code:

 

Siehe Beitrag #6

 

Also die erste Möglichkeit zeigt

Fehler beim kompilieren

und markiert

Public Sub Test()

 

hmm
warum heisst es in deinem oberen Bsp "Arbeit*.xl*" und im unteren auf einmal "NAME*.xl*"?

 

Guten Morgen,

habe das für das Forum verkürzt, dabei wohl der Fehler. Im Original stimmt das.

 

Also aktueller Status ist Beitrag #7.
War nun etwas verwirrend.

 

Ich verweise auf Beitrag #8

 

Die Idee in Beitrag #6 ergibt leider folgendes:

Fehlermeldung:

Fehler beim kompilieren

und markiert

Public Sub Test()

 

Gebe bitte nochmal alle Daten für den Kopiervorgang an:

Nach welchen Dateien soll gesucht werden?
(.xls oder .xlsx oder .xlsm oder nach allen Excel-Datein)

Wie sieht das Suchmuster des Dateinamens aus?
(Bsp:"Test*.xls") * = Platzhalter

Wird sich der Code in der Datei, in die kopiert werden soll, befinden?

Falls ja, in welches Blatt ab welcher Zeile und Spalte wird hineinkopiert?

Sollen nur Werte oder alles (auch Formate) kopiert werden?

Aus welchen Blatt der gefundenen Datei wird kopiert?
(Name des Blattes oder Position, oder sind es mehrere Blätter?)

Soll nach Makro-Start das ZielBlatt vorher gesäubert werden?