AW: zusammenfügen von tabellenblättern
19.04.2007 11:26:00
tabellenblättern
servus,
hab noch ne kleine Änderung vorgenommen, weil sonst die erste Zeile in tabelle3 mit gelöscht wird, wenn in tabelle3.A2 keine daten stehen und die erste zeile in tabelle2 kopiert wird (Kopf), wenn in tabelle2.a2 keine Daten stehen. Hier ist das nicht mehr so.
Sub test()
Dim lngLastRow As Long
Workbooks("test.xls").Sheets("Tabelle3").Activate 'Tabelle3 wird aktiviert
If Workbooks("test.xls").Sheets("Tabelle3").Range("A2").Value = "" Then 'prüfen ob a2 leer
Workbooks("test.xls").Sheets("Tabelle1").Activate 'geht zu Tabelle1
With Workbooks("test.xls").Sheets("Tabelle1")
lngLastRow = .Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Range("$A$2:$F$" & lngLastRow).Select
Selection.Copy 'kopieren des befüllten Bereichs in A:F
End With
Else
With Workbooks("test.xls").Sheets("Tabelle3")
lngLastRow = .Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, _
_
SearchDirection:=xlPrevious).Row
Range("$A$2:$F$" & lngLastRow).Select
Selection.Delete 'der Inhalt von A2 bis letzte volle Zeile im Bereich A:F _
wird gelö gesucht
End With
Workbooks("test.xls").Sheets("Tabelle1").Activate 'geht zu Tabelle1
With Workbooks("test.xls").Sheets("Tabelle1")
lngLastRow = .Cells.Find(What:="*", After:=Range("A1"), SearchOrder:= _
xlByRows, _
SearchDirection:=xlPrevious).Row
Range("$A$2:$F$" & lngLastRow).Select
Selection.Copy 'kopieren des befüllten Bereichs in A:F
End With
End If
Workbooks("test.xls").Sheets("Tabelle3").Activate 'geht zu Tabelle3
Workbooks("test.xls").Sheets("Tabelle3").Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Insert ' Daten einfügen
Workbooks("test.xls").Sheets("Tabelle2").Activate 'geht zu Tabelle2
If Workbooks("test.xls").Sheets("Tabelle2").Range("A2").Value = "" Then 'prüfen ob A2 leer
Workbooks("test.xls").Sheets("Tabelle1").Activate 'geht zu Tabelle3
Workbooks("test.xls").Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(1, 0).Select
Else
With Workbooks("test.xls").Sheets("Tabelle2")
lngLastRow = .Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, _
_
SearchDirection:=xlPrevious).Row
Range("$A$2:$F$" & lngLastRow).Select
Selection.Copy ' Daten kopieren
End With
Workbooks("test.xls").Sheets("Tabelle3").Activate 'geht zu Tabelle3
Workbooks("test.xls").Sheets("Tabelle3").Range("A65536").End(xlUp).Offset(1, 0). _
Select
Selection.Insert 'Daten einfügen (erste freie zelle)
End If
Workbooks("test.xls").Sheets("Tabelle2").Activate 'geht zu Tabelle2
Workbooks("test.xls").Sheets("Tabelle2").Range("A65536").End(xlUp).Offset(1, 0).Select
Workbooks("test.xls").Sheets("Tabelle1").Activate 'geht zu Tabelle1
Workbooks("test.xls").Sheets("Tabelle1").Range("A65536").End(xlUp).Offset(1, 0).Select
ThisWorkbook.Save
End Sub
Gruß
Chaos