Daten aus Dateien in Verzeichnis zusammenfasse
18.02.2011 09:22:52
fcs
Hallo Tommi,
mit Level VBA-bescheiden wird es möglicherweise etwas schwierig, da einiges prinzipiell umgestellt werden muss, wenn zunächst "nur" die Werte aus der Quelltabelle in ein leeres Blatt in der Zieltabelle kopiert und anschliessend formatiert werden sollen.
Gruß
Franz
Hier eine vereinfachte Fassung, die die Werte aus allen Dateien im Verzeichnis in eine neue Arbeitsmappe überträgt. Im Code muss du das Verzeichnis mit den Quelldateien anpassen.
Sub Zusammenführen_Tabellen()
' Führt die 1. Tabelle aus den Dateien in Verzeichnis in einer Datei zusammen
' Dabei werden die Werte aus den Quell-Tabellen in leere Tabellen _
in der Ziel-Datei kopiert
Dim Verzeichnis As String
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim Datei As String
Dim varAuswahl, sBlattName As String
'Verzeichnis mit den Dateien - anpassen !!!!
Verzeichnis = "C:\Users\Public\Test\Daten\"
Application.EnableEvents = False
Application.ScreenUpdating = False
'Exceldateien im Verzeichnis abarbeiten
Datei = Dir(Verzeichnis & "*.xls*")
Do Until Datei = ""
Application.StatusBar = "Datei " & Datei & " wird bearbeitet"
If LCase(Datei) LCase(ThisWorkbook.Name) Then
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open(Filename:=Verzeichnis & Datei, ReadOnly:=True)
Set wksQuelle = wbQuelle.Worksheets(1)
'Zieltabellenblatt anlegen
If wbZiel Is Nothing Then
'Neue Datei zum Zusammenführen der Tabellen Dateien anlegen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
Else
'Neues Blatt anfügen
wbZiel.Worksheets.Add After:=wbZiel.Sheets(wbZiel.Sheets.Count)
End If
With wbZiel
Set wksZiel = .Sheets(.Sheets.Count)
End With
'Zielblatt umbenennen
sBlattName = Left(Left(wbQuelle.Name, InStrRev(wbQuelle.Name, ".") - 1), 31)
wksZiel.Name = sBlattName
With wksQuelle
'Tabellendaten nach Ziel-Datei kopieren
.Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell)).Copy
wksZiel.Cells(1, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Range("a1").Select
End With
'Quelldatei ohne Speichern wieder schliessen
wbQuelle.Close Savechanges:=False
End If
'Kopierte Daten formatieren
Call Formatieren(wks:=wksZiel)
Datei = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
' Datei-Speichern Dialog anzeigen
If Not wbZiel Is Nothing Then
varAuswahl = Application.Dialogs(xlDialogSaveWorkbook).Show
End If
Application.EnableEvents = True
End Sub
Sub Formatieren(wks As Worksheet)
'Beispielhaft
With wks
.Columns(1).NumberFormat = "000" '001
.Columns(2).NumberFormat = "#,###.##" '22.111,01
.Columns(3).NumberFormat = "DD.MM.YYYY" '01.02.2011
.Columns.AutoFit 'Spaltenbreiten optimieren
End With
End Sub