VBA - Exel Dateien (aus Unterordnern) zusammenfass
18.02.2015 11:43:54
BODO
ich muss folgendes Problem lösen und hoffe, ihr könnt helfen (Excel 2010)! :-)
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 "NAME" heissen und die Inhalte zusammenfassen.
Hier mal mein aktueller Versuch und die Probleme damit:
- Unterordner werden nicht durchsucht, nur der Ordner 2 an sich
- 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.
---
Option Explicit
Sub Zusammenfassung()
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim sPfad As String
Dim sDatei As String
Dim lErgebnisZeile As Long
Dim s As Long
Dim z As Long
Set oTargetSheet = ActiveWorkbook.Sheets.Add
lErgebnisZeile = 1
sPfad = "\\PFAD\"
sDatei = Dir(CStr(sPfad & "NAME*.xl*"))
Do While sDatei ""
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True)
For z = 4 To oSourceBook.Sheets("NAME").UsedRange.Rows.Count
If Trim(CStr(oSourceBook.Sheets("NAME").Cells(z, 1).Value)) "" Then
For s = 1 To oSourceBook.Sheets("NAME").UsedRange.Columns.Count
oTargetSheet.Cells(lErgebnisZeile, s + 1).Value = _
oSourceBook.Sheets("NAME").Cells(z, s).Value
Next s
lErgebnisZeile = lErgebnisZeile + 1
End If
Next z
oSourceBook.Close False 'nicht speichern
sDatei = Dir()
Loop
Application.ScreenUpdating = True
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub