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