Makro Zusammenfassung bestimmter Bereich und Datum
17.06.2008 10:50:51
Sascha
Nochmals zur Ausgangslage: In einem Ordner liegen wöchentlich abgelegte Dateien, die alle identisch aufgebaut sind. Die Tabellenblätter heißen Montag, Dienstag... bis Samstag, zusätzlich ein Blatt Kunden mit den Stammdaten. Siehe: https://www.herber.de/bbs/user/52971.xls
Ich habe ein Makro gefunden und angepasst dass mir den gewünschten Ordner durchsucht und alle Tabellenblätter (bis auf das Blatt Kunden) aller Dateien in einem neuen Blatt untereinandergeschreiben zusammenfasst.
Nun hätte ich noch ein, zwei offene Punkte:
Hier das Makro:
Sub Zusammenführen_in_eine_Tabelle(Verzeichnis As String)
' Führt die Tabellen aus den Dateien in Verzeichnis in einer Datei zusammen
' Dabei werden die Daten aus den Tabellen der Quell-Dateien in eine oder mehr Ziel-Tabelle(n) _
kopiert
' Dabei werden in den Tabellen alle Formeln in Werte verwandelt
Dim wbQuelle As Workbook, wksQuelle As Worksheet, wbZiel As Workbook, wksZiel As Worksheet
Dim Datei As String, ZeileDaten As Long, Zeile As Long, wksListe As Worksheet
Dim Spaltenformat As Boolean, I As Integer, Blatt As Integer
'Neue Datei zum Zusammenführen der Tabellen Dateien anlegen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksZiel = wbZiel.Sheets(1)
Blatt = 1 'Zählnummer für Blätter mit Daten
wksZiel.Name = "Tabelle" & Blatt
wbZiel.Worksheets.Add After:=Sheets(1) 'Blatt das die zusammengefassten Tabellen _
protokolliert
Set wksListe = ActiveSheet
wksListe.Name = "Importprotokoll"
Zeile = 1
wksListe.Cells(Zeile, 1) = "Import-Protokoll"
Zeile = 2
wksListe.Cells(Zeile, 1) = "Quell-Datei"
wksListe.Cells(Zeile, 2) = "Quell-Tabelle"
wksListe.Cells(Zeile, 3) = "eingefügt in Blatt"
ZeileDaten = 1
Application.ScreenUpdating = False
'Exceldateien im Verzeichnis Öffnen
Datei = Dir(Verzeichnis & "*.xls")
Spaltenformat = False
Do Until Datei = ""
Application.StatusBar = "Die " & Zeile - 1 & ". Datei wird bearbeitet, Dateiname: " & Datei
Set wbQuelle = Workbooks.Open(FileName:=Verzeichnis & Datei, ReadOnly:=True)
For Each wksQuelle In wbQuelle.Worksheets 'Variante für alle Tabellenblätter
If wksQuelle.Name "Kunden" Then
With wksQuelle
If ZeileDaten + .UsedRange.Rows.Count > wksZiel.Rows.Count Then
Blatt = Blatt + 1
wbZiel.Worksheets.Add After:=Sheets(Blatt - 2) 'weiteres Blatt für Daten
Set wksZiel = wbZiel.Sheets(Blatt)
wksZiel.Name = "Tabelle" & Blatt
Spaltenformat = False
ZeileDaten = 1
End If
If Spaltenformat = False Then
'Aus der 1. Tabelle der nächsten, Datei werden die Spaltenbreiten ausgelesen und in _
die Ziel-Tabelle übertragen
For I = 1 To .UsedRange.Column + .UsedRange.Columns.Count - 1
wksZiel.Columns(I).ColumnWidth = .Columns(I).ColumnWidth
Next I
Spaltenformat = True
End If
Zeile = Zeile + 1
wksListe.Cells(Zeile, 1) = wbQuelle.FullName
wksListe.Cells(Zeile, 2) = wksQuelle.Name
wksListe.Cells(Zeile, 3) = Blatt
'Formeln durch Werte ersetzen
.UsedRange.Copy
.Range(.UsedRange.Address).PasteSpecial Paste:=xlPasteValues
.UsedRange.EntireRow.Copy Destination:=wksZiel.Cells(ZeileDaten, 1)
ZeileDaten = ZeileDaten + .UsedRange.Rows.Count
End With
End If
Next wksQuelle
wbQuelle.Close Savechanges:=False
Datei = Dir
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
wbZiel.Activate
'Protokollliste Formatieren
wksListe.Select
wksListe.Columns("A:B").AutoFit
wksListe.Range("A3").Select
ActiveWindow.FreezePanes = True
' Datei-Speichern Dialog anzeigen
Application.Dialogs(xlDialogSaveWorkbook).Show
End Sub
fcs und case hatten mich im ersten Posting ja schon ein paar Schritte weitergebracht, besten dank nochmals dafür!
Sascha