Tabellen zusammenführen

Hallo zusammen,
vorab: ich hab dieses Problem schon einmal hier dargestellt, konnte es aber leider nicht lösen, da meine vba kentnisse bescheidener als bescheiden sind :)
Meine 2 Probleme:
erstens:
ich möchte 2 Tabellenblätter zu einer großen Tabelle zusammenführen. Spaltennamen, Breiten und Formate sind bei beiden Tabelle identisch.
Leerzeilen soll es keine geben und die 2. Tabelle soll gleich im Anschluss an die 1. Tabelle angefügt werden.
zweitens:
Wenn die Gesamttabelle erstellt ist soll der gesamte Inhalt (Bereich A:M) ohne die Spaltenüberschriften und nur der bereich der beschrieben ist, in die Zwischenablage kopiert werden, da diese in ein anderes Programm eingefügt werden soll.
das alles soll über eine schaltfläche passieren.
Wär super wenn ihr mir irgendwie weiterhelfen könntet. eine Beispieldatei hab ich angehängt.
Danke und Gruß
Flo
https://www.herber.de/bbs/user/61921.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Beispiel() Dim LRow As Long Dim Bereich As Range Sheets("Zusammengeführt").UsedRange.Clear 'Datenblatt 1 ***************************************************************** With Sheets("Datenblatt 1") On Error Resume Next 'letzte Zeile bestimmen LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False).Row LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row) On Error GoTo 0 Set Bereich = .Range("A1", .Cells(LRow, .Columns.Count)) 'Bereich festlegen End With 'Bereich kopieren Bereich.Copy Sheets("Zusammengeführt").Range("A1") '******************************************************************************* 'Datenblatt 2 ****************************************************************** With Sheets("Datenblatt 2") On Error Resume Next 'letzte Zeile bestimmen LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False).Row LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row) On Error GoTo 0 Set Bereich = .Range("A2", .Cells(LRow, .Columns.Count)) 'Bereich festlegen End With '******************************************************************************* With Sheets("Zusammengeführt") On Error Resume Next 'letzte Zeile bestimmen LRow = .Cells.Find("*", , xlValues, 2, 1, 2, False, False).Row LRow = Application.Max(LRow, .Cells.Find("*", , xlFormulas, 2, 1, 2).Row) On Error GoTo 0 'Bereich kopieren Bereich.Copy .Cells(LRow + 1, 1) .UsedRange.Value = .UsedRange.Value .UsedRange.EntireColumn.AutoFit .UsedRange.Copy End With End Sub

Hallo,
habe den Code etwas umgestellt.
Teste mal.

Option Explicit

Sub Beispiel()
Dim LRow As Long
Dim Bereich As Range


Sheets("Zusammengeführt").UsedRange.Clear

    'Datenblatt 1 ***************************************************************** 
    With Sheets("Datenblatt 1")
        On Error Resume Next
         'letzte Zeile bestimmen 
         LRow = .UsedRange.Find("*", , xlValues, 2, 1, 2, False, False).Row
         LRow = Application.Max(LRow, .UsedRange.Find("*", , xlFormulas, 2, 1, 2).Row)
        On Error GoTo 0
     
     Set Bereich = .Range("A1", .Cells(LRow, .Columns.Count)) 'Bereich festlegen 
    
    End With
    'Bereich kopieren 
    Bereich.Copy Sheets("Zusammengeführt").Range("A1")
    '******************************************************************************* 

    'Datenblatt 2 ****************************************************************** 
    With Sheets("Datenblatt 2")
        On Error Resume Next
         'letzte Zeile bestimmen 
         LRow = .UsedRange.Find("*", , xlValues, 2, 1, 2, False, False).Row
         LRow = Application.Max(LRow, .UsedRange.Find("*", , xlFormulas, 2, 1, 2).Row)
        On Error GoTo 0
     Set Bereich = .Range("A2", .Cells(LRow, .Columns.Count)) 'Bereich festlegen 
    End With
    '******************************************************************************* 

    With Sheets("Zusammengeführt")
        On Error Resume Next
         'letzte Zeile bestimmen 
         LRow = .UsedRange.Find("*", , xlValues, 2, 1, 2, False, False).Row
         LRow = Application.Max(LRow, .UsedRange.Find("*", , xlFormulas, 2, 1, 2).Row)
        On Error GoTo 0
      
      'Bereich kopieren 
      Bereich.Copy .Cells(LRow + 1, 1)
     
     .UsedRange.Value = .UsedRange.Value
     .UsedRange.EntireColumn.AutoFit
        
        On Error Resume Next
         'letzte Zeile bestimmen 
         LRow = .UsedRange.Find("*", , xlValues, 2, 1, 2, False, False).Row
         LRow = Application.Max(LRow, .UsedRange.Find("*", , xlFormulas, 2, 1, 2).Row)
        On Error GoTo 0
     
     .Range("A2", .Cells(LRow, 13)).Copy
    End With

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread