AW: Tabellen zusammenführen
20.05.2009 11:42:46
Tino
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