Hallo Andrea,
versuch mal:
Option Explicit
Sub KopiereBereich()
Dim Zieltab As Worksheet, i As Long
Dim LetzteZeileZieltab As Long, LetzteSpalteZieltab As Long
Set Zieltab = ActiveWorkbook.Worksheets("Test")
Application.ScreenUpdating = False
For i = 5 To Worksheets.Count
With Worksheets(i)
If .Cells(1, 3) <> "" Then
LetzteZeileZieltab = Zieltab.Cells(Zieltab.Rows.Count, 2).End(xlUp).Offset(1).Row
.Range("C1:C13").Copy
Zieltab.Cells(LetzteZeileZieltab, 2).PasteSpecial Transpose:=True
LetzteSpalteZieltab = Zieltab.Cells(LetzteZeileZieltab, Zieltab.Columns.Count).End(xlToLeft).Offset(, 1).Column
.Range(.Cells(15, 3), .Cells(.Cells(Rows.Count, 3).End(xlUp).Row, 3)).Copy
Zieltab.Cells(LetzteZeileZieltab, LetzteSpalteZieltab).PasteSpecial Transpose:=True
LetzteSpalteZieltab = Zieltab.Cells(LetzteZeileZieltab, Zieltab.Columns.Count).End(xlToLeft).Offset(, 1).Column
.Range(.Cells(15, 4), .Cells(.Cells(Rows.Count, 4).End(xlUp).Row, 4)).Copy
Zieltab.Cells(LetzteZeileZieltab, LetzteSpalteZieltab).PasteSpecial Transpose:=True
LetzteSpalteZieltab = Zieltab.Cells(LetzteZeileZieltab, Zieltab.Columns.Count).End(xlToLeft).Offset(, 1).Column
.Range(.Cells(15, 13), .Cells(.Cells(Rows.Count, 13).End(xlUp).Row, 13)).Copy
Zieltab.Cells(LetzteZeileZieltab, LetzteSpalteZieltab).PasteSpecial Transpose:=True
LetzteSpalteZieltab = Zieltab.Cells(LetzteZeileZieltab, Zieltab.Columns.Count).End(xlToLeft).Offset(, 1).Column
.Range(.Cells(15, 14), .Cells(.Cells(Rows.Count, 14).End(xlUp).Row, 14)).Copy
Zieltab.Cells(LetzteZeileZieltab, LetzteSpalteZieltab).PasteSpecial Transpose:=True
Application.CutCopyMode = False
End If
End With
Next i
Set Zieltab = Nothing
End Sub
Gruß Werner
|