AW: Inhalte aus mehreren Dateien zusammenfassen Ma
17.06.2008 08:49:35
Sascha
Ich habe nun folgendes Makro gefunden, was zu teilen schon das tut was ich will:
Dieses Makro führt die Inhalte alle vorhandenen Tabellenblätter aus allen Mappen in ein neues Blatt zusammen.
Wie kann ich den nun festlgend, dass nur die Blätter, Montag, Dienstag, Mittwoch, Donnerstag, Freitag und Samstag kopiert werden? Und hier auch nur vonB1 bis AC50 ?
Vielen Dank
Sascha
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
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
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