ohje, wie krieg ich denn den code hier vernümftig rein?!? nächster versuch:
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
'On Error GoTo Fehlerbehandlung
'Daten der Anlage übernehmen
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
'For J = 15 To LetzteZeileQuelltab
Worksheets(I).Range(Cells(J, 1), Cells(LetzteZeileQuelltab, 1)).Copy _
Destination:=Worksheets(Zieltab).Range(Cells(LetzteZeileZieltab, 16), Cells(LetzteZeileQuelltab LetzteZeileZieltab + 1, 16))
', (Range("K" & J & ":K" & LetzteZeileQuelltab))).Select
'Worksheets(Zieltab).Cells("O" & LetzteZeileZieltab).Select
'Worksheet(Zieltab).Range(.Cells(LetzteZeileZieltab, 16), .Cells( LetzteZeileZieltab + LetzteZeileQuelltab, 16)).Paste
'LetzteZeileQuelltab = LetzteZeileQuelltab + 1
'Next J
End If
Next I
Fehlerbehandlung:
End Sub
|