Makro mehrere Tabellen zusammenfügen

Hallo zusammen,
ich bin keine Makro Expertin, deswegen benoetige ich Eure Hilfe.
Es gibt mehrere Excel Dateien, in jeder Datei ein Bestimmter Arbeitsblatt "Summary".
Die Namen von den Dateien koennen von Woche zur Woche geaendert werden. Der Name von diesem Arbeitsblatt bleibt Kostant in jeder Datei, hat aber keinen bestimmten Platz (muss nicht unbedingt das erste Arbeitsblatt sein)
Also wenn Makro startet, soll fragen "bitte die Dateien auswaehlen" , damit kann man bestimmen wieviele Dateien zusammengefuehrt werden sollen.
Die Summaries erhalten auch Formeln und Verknuepfungen zu den anderen Arbeitsblaettern, deswegen es ist wichtig, dass in die Zusammenfassung Inhalte eingefuegt werden sollen, damit die Ergebnisse nicht geaendert werden. Die Anzahl von Spalten ist gleich von A bis S, die Anzahl von Zeilen ist in jeder Summary unterschiedlich.
Ich haette gerne auch die Formatierung aus den originalen Summaries uebernommen.
Nach jeder Summary in der Zusammenfassung benoetige ich einen Seitenumbruch, damit die Summaries spaeter problemlos einzeln ausgedruckt werden koennen.
Es waere ganz toll wenn mir Jemand helfen koennte. Ich benutze Makros gerne, kann die leider selbst nicht schreiben. Ich bedanke mich im Voraus!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub DateienAuswaehlen() Dim strVerz() As String Dim objSheet As Object Dim objSheets As Object Dim strSheet As String Dim lngCount As Long, lngCount2 As Long Dim objZiel As Object, objQuelle As Object Set objZiel = ThisWorkbook objZiel.Sheets("Summary").Range("A:A").ClearContents With Application.FileDialog(msoFileDialogFilePicker) 'Dateien auswählen .AllowMultiSelect = True .Filters.Clear .InitialFileName = "C:\" 'Hier steht das Default- Verzeichnis .Title = "Dateiauswahl" .ButtonName = "Auswahl..." .InitialView = msoFileDialogViewDetails .Show For lngCount = 1 To .SelectedItems.Count ReDim Preserve strVerz(lngCount) strVerz(lngCount) = .SelectedItems(lngCount) Next lngCount End With For lngCount2 = 1 To lngCount - 1 Application.Workbooks.Open (strVerz(lngCount2)) Set objQuelle = ActiveWorkbook Set objSheets = objQuelle.Worksheets For Each objSheet In objSheets If objSheet.Name = "Summary" Then 'Hier den Code zum Kopieren einfügen!! End If Next objSheet objQuelle.Close Next lngCount2 End Sub

Option Explicit Sub DateienAuswaehlen() Dim strVerz() As String 'Array- Variable für Pfade der ausgewählten Dateien Dim objSheet As Object 'Tabellenblatt der Quell-Datei Dim objSheets As Object 'Alle Tabellenblaetter der Quell-Datei Dim lngCount As Long, lngCount2 As Long 'Zaehler fuer die Schleifen Dim lngLZeileZiel As Long, lngLZeileQuelle As Long 'Letzte Zeile mit Inhalt Dim objZiel As Object, objQuelle As Object 'Variablen für Ziel-Tabelle und Quell-Datei Set objZiel = ThisWorkbook.Sheets("Summary") 'Zieltabelle zuweisen objZiel.Range("A:S").Clear 'Inhalte in Zieltabelle loeschen 'Dateidialogfeld öffnen, über das der Benutzer eine oder mehrere Dateien auswählen kann With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Filters.Clear .InitialFileName = "C:\" 'Hier steht das Default- Verzeichnis .Title = "Dateiauswahl" .ButtonName = "Auswahl..." .InitialView = msoFileDialogViewDetails .Show 'Die Pfade der ausgewählten Dateien in einer Array-Variablen ablegen For lngCount = 1 To .SelectedItems.Count ReDim Preserve strVerz(lngCount) strVerz(lngCount) = .SelectedItems(lngCount) Next lngCount End With 'Die ausgewählten Dateien in einer Schleife nacheinander öffnen For lngCount2 = 1 To lngCount - 1 Application.Workbooks.Open (strVerz(lngCount2)) 'Quell- Datei öffnen Set objQuelle = ActiveWorkbook Set objSheets = objQuelle.Worksheets 'In einer zweiten Schleife nach einem Tabellenblatt "Summary" suchen For Each objSheet In objSheets If objSheet.Name = "Summary" Then 'Letzte Zeile mit einem Eintrag in der Quell-Tabelle und der Ziel-Tabelle _ herausfinden If objZiel.Range("A1") = "" Then lngLZeileZiel = 1 Else lngLZeileZiel = objZiel.Cells.Find(What:="*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 End If lngLZeileQuelle = objSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row 'Daten kopieren und in die Zieltabelle einfügen objSheet.Cells(1, 1).Resize(lngLZeileQuelle, 19).Copy _ Destination:=objZiel.Cells(lngLZeileZiel, 1).Resize(lngLZeileQuelle, 19) 'Seitenumbruch einfügen objZiel.Rows(lngLZeileZiel + lngLZeileQuelle).PageBreak = xlPageBreakManual End If Next objSheet objQuelle.Close 'Quell- Datei schließen Next lngCount2 End Sub

...es sollten ja nur Werte und Formatierungen übertragen werden und keine Formeln.

Option Explicit
Sub DateienAuswaehlen()
Dim strVerz() As String  'Array- Variable für Pfade der ausgewählten Dateien
Dim objSheet As Object   'Tabellenblatt der Quell-Datei
Dim objSheets As Object  'Alle Tabellenblaetter der Quell-Datei
Dim lngCount As Long, lngCount2 As Long  'Zaehler fuer die Schleifen
Dim lngLZeileZiel As Long, lngLZeileQuelle As Long  'Letzte Zeile mit Inhalt
Dim objZiel As Object, objQuelle As Object  'Variablen für Ziel-Tabelle und Quell-Datei
Set objZiel = ThisWorkbook.Sheets("Summary")    'Zieltabelle zuweisen
objZiel.Range("A:S").Clear                      'Inhalte in Zieltabelle loeschen
'Dateidialogfeld öffnen, über das der Benutzer eine oder mehrere Dateien auswählen kann
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Clear
.InitialFileName = "C:\"   'Hier steht das Default- Verzeichnis
.Title = "Dateiauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewDetails
.Show
'Die Pfade der ausgewählten Dateien in einer Array-Variablen ablegen
For lngCount = 1 To .SelectedItems.Count
ReDim Preserve strVerz(lngCount)
strVerz(lngCount) = .SelectedItems(lngCount)
Next lngCount
End With
'Die ausgewählten Dateien in einer Schleife nacheinander öffnen
For lngCount2 = 1 To lngCount - 1
Application.Workbooks.Open (strVerz(lngCount2)) 'Quell- Datei öffnen
Set objQuelle = ActiveWorkbook
Set objSheets = objQuelle.Worksheets
'In einer zweiten Schleife nach einem Tabellenblatt "Summary" suchen
For Each objSheet In objSheets
If objSheet.Name = "Summary" Then
'Letzte Zeile mit einem Eintrag in der Quell-Tabelle und der Ziel-Tabelle  _
herausfinden
If objZiel.Range("A1") = "" Then
lngLZeileZiel = 1
Else
lngLZeileZiel = objZiel.Cells.Find(What:="*", SearchOrder:=xlByRows,  _
SearchDirection:=xlPrevious).Row + 1
End If
lngLZeileQuelle = objSheet.Cells.Find(What:="*", SearchOrder:=xlByRows,  _
SearchDirection:=xlPrevious).Row
'Daten kopieren und in die Zieltabelle einfügen
objSheet.Cells(1, 1).Resize(lngLZeileQuelle, 19).Copy
With objZiel.Cells(lngLZeileZiel, 1).Resize(lngLZeileQuelle, 19)
.PasteSpecial Paste:=xlPasteValues    'Werte einfügen
.PasteSpecial Paste:=xlPasteFormats   'Formate einfügen
End With
'Seitenumbruch einfügen
objZiel.Rows(lngLZeileZiel + lngLZeileQuelle).PageBreak = xlPageBreakManual
End If
Next objSheet
objQuelle.Close  'Quell- Datei schließen
Next lngCount2
End Sub

Beliebteste Forumthreads (12 Monate)

Makro mehrere Tabellen zusammenfügen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread