Makro mehrere Tabellen zusammenfügen.

Question

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!

Answer 1

Hallo,

kannst du uns Beispieltabellen zur Verfügung stellen?
Z.B. hier rüber

www.file-upload.net/?why=2

dann link hier hinterlegen

Gruß

Helmut

Answer 2

Hallo Helmut,

ich werde die Dateien heute Abend hochladen.

Danke Dir.

Answer 3

Hallo Olga,

das Makro gehört in ein allgemeines Modul deiner Zielarbeitsmappe. Die Daten werden in das Blatt deiner Zielarbeitsmappe kopiert, das gerade aktiv ist, wenn das Makro gestartet wird.

Schau mal, ob es so funktioniert, wie du willst:

Sub Oeffnen_und_kopieren()
Dim Datei, Dateien As Variant
Dim Quelle, Ziel, WSZiel As String
Dim bExists, MappeOffen As Boolean
Dim i As Integer
Dim lZeile, lqZeile As Long
Dim Rückgabe

'Name des Arbeitsblatts, in den die Daten hereinkopiert werden, hier das aktuelle Blatt
WSZiel = ActiveSheet.Name

'Datei-Öffnen Dialog aufrufen
Dateien = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", _
Title:="Eine oder mehrere Dateien zum Öffnen auswählen", _
MultiSelect:=True)

If IsArray(Dateien) = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
Exit Sub
End If

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'ausgewählte Dateien öffnen
For n = LBound(Dateien) To UBound(Dateien)
Datei = Dateien(n)

'Prüfen, ob Datei schon offen ist
For i = 1 To Workbooks.Count
If Workbooks(i).FullName = Datei Then
'ausgewählte Mappe ist bereits offen
MappeOffen = True
'Frage, ob Daten kopiert werden sollen
Rueckgabe = MsgBox("Die Arbeitsmappe " & Workbooks(i).Name & " ist bereits offen! Sollen die Daten kopiert werden?", vbYesNo + vbQuestion, "Mappe bereits offen")
'Abbruch des Makros
If Rueckgabe = vbNo Then Exit Sub
'Name der Quelldatei in Variable schreiben
Quelle = Workbooks(i).Name
End If
Next i

'ausgewählte Datei öffnen, falls diese noch nicht offen ist
If MappeOffen = False Then
Workbooks.Open (Datei)
'Name der Quelldatei in Variable schreiben
Quelle = ActiveWorkbook.Name
End If

'Name der Zielarbeitsmappe wird in Variable geschrieben
Ziel = ThisWorkbook.Name

'Prüfen, ob Tabellenblatt mit Namen Summary in Quelldatei existiert
For i = 1 To Workbooks(Quelle).Sheets.Count
If Workbooks(Quelle).Sheets(i).Name = "Summary" Then
bExists = True: Exit For
End If
Next i

'Abbruch des Makros falls kein Arbeitsblatt mit dem Namen Summary existiert
If bExists = False Then
MsgBox "In der Arbeitsmappe " & Quelle & " existiert kein Arbeitsblatt mit dem Namen Summary! Abbruch!", 16, "Fehlermeldung"
Else
'Festlegen der Zeile zum Einfügen der Daten in Zielarbeitsblatt
lZeile = Workbooks(Ziel).Sheets(WSZiel).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

'Ermitteln der letzten Zeile in Quellarbeitsmappe
lqZeile = Workbooks(Quelle).Sheets("Summary").UsedRange.SpecialCells(xlCellTypeLastCell).Row

'Daten kopieren
With Workbooks(Quelle).Worksheets("Summary")
.Range(.Cells(1, 1), .Cells(lqZeile, 19)).Copy
End With
With Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 1)
.PasteSpecial Paste:=xlPasteValues 'Werte kopieren
.PasteSpecial Paste:=xlPasteFormats 'Formate kopieren
End With
'Seitenumbruch einfügen
Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile + 1, 1).PageBreak = xlPageBreakManual

'Quelldatei schließen, wenn diese über das Makro geöffnet wurde
If MappeOffen = False Then Workbooks(Quelle).Close

End If

Next n

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

'Meldung, dass Daten kopiert wurden
MsgBox "Die Daten wurden kopiert!", 64, "Information"

End Sub

Gruß

M.O.

Answer 4

Vielen Dank! Ich werde es testen und ueber die Ergebnisse berichten. Schoenen Abend noch!. :)

Gruß Olga

Answer 5

Guten Morgen M.O.,


das Makro ist fast perfekt!

Noch ein Paar Aenderungen haette ich gerne, falls es geht.
Kann man noch einen Befehl hinzufuegen indem das Arbeitsblatt zuest komplett von den alten Eintraegen bereinigt wird, bevor die aktuellen Daten reinkopiert werden?

Und noch eine Kleinigkeit.
Seitenumbrueche schneiden die Tabellenueberschriften, sie starten um eine oder zwei Zeilen tiefer als die ersten Tabellenzeilen. Sie sollen mit der ersten Tabellenzeilen beginnen, wenn es geht.
Kann man die Groesse von Seitenumbruechen festlegen? Zum Beispiel die Anzahl von Zeilen 35 und Anzahl von Spalten 20 fuer jede Tabelle?

Ich bedanke mich sehr.
Gruesse Olga.

Answer 6

Hallo Olga,

hier das angepasste Makro:

Sub Oeffnen_und_kopieren()
Dim Datei, Dateien As Variant
Dim Quelle, Ziel, WSZiel As String
Dim bExists, MappeOffen As Boolean
Dim i As Integer
Dim lZeile, lqZeile As Long
Dim Rückgabe


'Name des Arbeitsblatts, in den die Daten hereinkopiert werden, hier das aktuelle Blatt
WSZiel = ActiveSheet.Name

'Datei-Öffnen Dialog aufrufen
Dateien = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", _
Title:="Eine oder mehrere Dateien zum Öffnen auswählen", _
MultiSelect:=True)

If IsArray(Dateien) = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
Exit Sub
End If

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Benachrichtigungen ausschalten
Application.DisplayAlerts = False

'alle Daten im Zielarbeitsblatt löschen
With ActiveSheet
.Range("A1", Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 1)).EntireRow.Delete xlShiftUp
End With

'ausgewählte Dateien öffnen
For n = LBound(Dateien) To UBound(Dateien)
Datei = Dateien(n)

'Prüfen, ob Datei schon offen ist
For i = 1 To Workbooks.Count
If Workbooks(i).FullName = Datei Then
'ausgewählte Mappe ist bereits offen
MappeOffen = True
'Frage, ob Daten kopiert werden sollen
Rueckgabe = MsgBox("Die Arbeitsmappe " & Workbooks(i).Name & " ist bereits offen! Sollen die Daten kopiert werden?", vbYesNo + vbQuestion, "Mappe bereits offen")
'Abbruch des Makros
If Rueckgabe = vbNo Then Exit Sub
'Name der Quelldatei in Variable schreiben
Quelle = Workbooks(i).Name
End If
Next i

'ausgewählte Datei öffnen, falls diese noch nicht offen ist
If MappeOffen = False Then
Workbooks.Open (Datei)
'Name der Quelldatei in Variable schreiben
Quelle = ActiveWorkbook.Name
End If

'Name der Zielarbeitsmappe wird in Variable geschrieben
Ziel = ThisWorkbook.Name

'Prüfen, ob Tabellenblatt mit Namen Summary in Quelldatei existiert
For i = 1 To Workbooks(Quelle).Sheets.Count
If Workbooks(Quelle).Sheets(i).Name = "Summary" Then
bExists = True: Exit For
End If
Next i

'Abbruch des Makros falls kein Arbeitsblatt mit dem Namen Summary existiert
If bExists = False Then
MsgBox "In der Arbeitsmappe " & Quelle & " existiert kein Arbeitsblatt mit dem Namen Summary! Abbruch!", 16, "Fehlermeldung"
Else
'Festlegen der Zeile zum Einfügen der Daten in Zielarbeitsblatt
If n = 1 Then
lZeile = 1 'beim ersten Durchgang wird Zeilennummer auf 1 gesetzt
Else
lZeile = Workbooks(Ziel).Sheets(WSZiel).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
End If

'Ermitteln der letzten Zeile in Quellarbeitsmappe
lqZeile = Workbooks(Quelle).Sheets("Summary").UsedRange.SpecialCells(xlCellTypeLastCell).Row

'Daten kopieren
With Workbooks(Quelle).Worksheets("Summary")
.Range(.Cells(1, 1), .Cells(lqZeile, 19)).Copy
End With
With Workbooks(Ziel).Sheets(WSZiel).Cells(lZeile, 1)
.PasteSpecial Paste:=xlPasteValues 'Werte kopieren
.PasteSpecial Paste:=xlPasteFormats 'Formate kopieren
End With


'Quelldatei schließen, wenn diese über das Makro geöffnet wurde
If MappeOffen = False Then Workbooks(Quelle).Close

End If

Next n


'Seitenumbrüche einfügen
lZeile = Workbooks(Ziel).Sheets(WSZiel).UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 36 To lZeile Step 35
Workbooks(Ziel).Sheets(WSZiel).Cells(i, 20).PageBreak = xlPageBreakManual
Next i

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

'Benachrichtigungen einschalten
Application.DisplayAlerts = True

'Meldung, dass Daten kopiert wurden
MsgBox "Die Daten wurden kopiert!", 64, "Information"


End Sub

Es werden jetzt wie von dir gewünscht nach 35 Zeilen und nach Spalte 20 (Spalte S ist ja 19) manuelle Seitenumbrüche eingefügt.
Beachte aber, dass ggf. vorhandene automatische Seitenumbrüche in Excel nicht unbedingt aufgehoben werden müssen (insbesondere bei
den Spalten, wenn diese breiter sind).

Gruß

M.O.

Answer 7

Vielen herzlichen Dank M.O.! Es funkzioniert ganz toll!
Ich wuensche Dir noch alles Gute! :)

Gruesse Olga.

Answer 8

Hallo Olga,

freut mich, dass das Makro so läuft wie du es willst :-). Und danke für die Rückmeldung.

Gruß

M.O.