Hallo Werner,

vielen lieben Dank für deine Rückmeldung und die Zeit, die du dir dafür genommen hast. Ja, du hast Recht mit deiner Kritik.

So, dann versuch ich es jetzt besser zu machen.

Das Makro soll folgendes tun:

1. alle Tabellen durchsuchen, ob ein Wert in C1 steht und dann

2. Einen bestimmten definierten Bereich (C1 bis C13) makieren und transponiert in die Tabelle Test einfügen.

2.1. und dann zusätzlich die Zellen von Zeile 15 bis zu letzten benutzen Zeile bestimmte Spalten (C,D,M und N) an den gerade erstellten Datensatz rechts anfügen (das war die Spalte 16).

-> dann zur nächsten Tabelle

Punkt 1 und 2 hat super mit meinem vorhanden Makro geklappt, nur dann Punkt 2.1. hat zu Problemen geführt (Laufzeitfehler). Dein Makro bildet auch 1. und 2. ab, daher ist mein Problem noch nicht gelöst.

Ich hoffe das war jetzt etwas deutlicher.

so und nun füge ich nochmal richtig meinen Code ein, weil ich jetzt auch weiß, wie das geht :-)

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

Vielleicht hast du nochmal einen Lösungsansatz für mich.

Vielen Dank vorab.