Alle Inhalte mehrerer Tabellen einer Excel-Mappe zusammenführen

Hallo,

ich habe folgendes Problem und hoffe, dass vielleicht jemand einen Tip für mich hat. =).

Ich bekomme monatlich eine Excel-Datei (also eine Mappe), die sehr viele Tabellen enthält. (1 XLS-Datei mit 1 Mappe mit n Tabellen) Alle Zeilen aller Tabellen muss ich nun in eine neue Tabelle zusammenführen (einfach untereinander einfügen). Bisher habe ich es so gemacht, dass ich in einer neuen Mappe eine neue Tabelle angelegt habe, dann aus jeder vorhandenen Tabelle (1..n, Mappe 1) alle Zeilen per STRG-C kopiert habe und diese dann mit STRG-V am Ende der neu angelegten Tabelle eingefügt habe.

Kennt jemand eine Möglichkeit dies irgendwie zu automatisieren? Wäre dankbar für jeden Tip! =)

Grüße
flipflip

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 114612

Url: https://administrator.de/forum/alle-inhalte-mehrerer-tabellen-einer-excel-mappe-zusammenfuehren-114612.html

Ausgedruckt am: 24.12.2024 um 12:12 Uhr

3 Kommentare

Neuester Kommentar

Hallo flipflip,

verstehe ich das richtig, Du hast eine *.xls-Datei, die heisst Mappe1.xls und hat mehrere Tabellblätter. Und Du möchtest aus allen Tabellenblättern alle Zeilen in eine andere Import.xls-Datei in eine Tabelle einlesen?

Befindet sich die Datei Mappe1.xls im gleichen Ordner, wie die Import.xls?

Gruß Dieter

PS Wie sind die Zeilen Spalten aufgeteilt. Alles gleichmäßig unter- und nebeneinander? Bitte Beispiel?

Hallo flipflip,

das Makro, kannst Du im VB-Editor in "DieseArbeitsmappe" Deiner Import.xls reinkopieren und wieder zurück in der Excel-Tabellenansicht über Extras><Makro><Makros><Optionen> mit einer Tastenkombination verknüpfen und starten.

Es wird angenommen, das die sich die zu kopierenden Zellen in der Datei Mappe1.xls befinden. Auch wird angenommen, dass sich diese Datei im selben Ordner befindet, wie die andere Datei.

Ansonsten im Makro den Dateinamen oder Pfad ändern.

Sub ImportCells()
    Dim iWkb As Workbook, iWks As Worksheet, eWks As Worksheet, EndLine As Long

    On Error GoTo Ende
    
    Set eWks = ActiveWorkbook.ActiveSheet
    Set iWkb = Workbooks.Open(ThisWorkbook.Path & "\Mappe1.xls") '("Pfad")  
    
    For Each iWks In iWkb.Worksheets
        iWks.Range("A1", iWks.Cells.SpecialCells(xlLastCell)).Copy  
        With eWks
            EndLine = .Cells(.Rows.Count, 1).End(xlUp).Row
            If EndLine > 1 Then EndLine = EndLine + 1
           .Paste Destination:=.Cells(EndLine, 1)
        End With
    Next
    Application.CutCopyMode = False:  iWkb.Close
    Exit Sub
Ende:
    MsgBox "Unbekannter Fehler", vbExclamation, "Fehler"  
End Sub