Sub KopiereBereich()
Dim Quelltab As Worksheet
Dim Zieltab As Worksheet
Dim Zelle As Range
Dim Zaehler As Long
Set Zieltab = ActiveWorkbook.Worksheets("Test")
Dim i As Long
Dim J As Long
Dim LetzteZeileZieltab As Long
Dim LetzteZeileQuelltab As Long
For i = 5 To Worksheets.Count
If Worksheets(i).Cells(1, 3).Value <> "" Then
LetzteZeileZieltab = Zieltab.Cells(Rows.Count, 2).End(xlUp).Row
LetzteZeileZieltab = LetzteZeileZieltab + 1
Worksheets(i).Range("C1:C13").Copy
Zieltab.Cells(LetzteZeileZieltab, 2).PasteSpecial Transpose:=True
Application.CutCopyMode = False
LetzteZeileQuelltab = Worksheets(i).Cells(Rows.Count, 2).End(xlUp).Row
Worksheets(i).Range(Cells(J, 1), Cells(LetzteZeileQuelltab, 1)).Copy Destination:=Worksheets(Zieltab).Range(Cells(LetzteZeileZieltab, 16), Cells(LetzteZeileQuelltab + LetzteZeileZieltab + 1, 16))
End If
Next i
Fehlerbehandlung:
End Sub