Sub DatenKopieren()

    Dim aktA As Worksheet ' Aktuelles Arbeitsblatt
    Dim letzA As Worksheet ' Letztes Arbeitsblatt
    Dim letzteZeile As Long ' Letzte belegte Zeile in aktA
    Dim i As Long ' Zählvariable für Schleife
    Dim rowOffset As Long ' Offset für das Einfügen in letzA

    ' Aktuelles Arbeitsblatt zuweisen
    Set aktA = ThisWorkbook.Sheets(3) ' Setze das aktuelle Arbeitsblatt auf das dritte Arbeitsblatt

    ' Letztes Arbeitsblatt hinzufügen
    Set letzA = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

    ' Kopieren der Zeile 141 von aktA nach letzA in Zeile 1
    aktA.Rows(141).Copy Destination:=letzA.Rows(1)

    ' Anzahl der belegten Zeilen in aktA bestimmen
    letzteZeile = aktA.Cells(aktA.Rows.Count, "A").End(xlUp).Row

    ' Kopieren von Zellen B2 bis B? aus aktA nach letzA entsprechend der Regel
    For i = 2 To letzteZeile - 5 ' -5, da die Nummerierung bei A6 beginnt und wir bis zur letzten Nummerierung kopieren wollen
        Select Case i
            Case 2
                letzA.Cells(2, "C").Value = aktA.Cells(2, "B").Value
            Case 3
                letzA.Cells(2, "J").Value = aktA.Cells(3, "B").Value
            Case 4
                letzA.Cells(2, "Q").Value = aktA.Cells(4, "B").Value
            Case Else
                letzA.Cells(i - 1, "K").Value = aktA.Cells(i, "A").Value & vbCrLf & aktA.Cells(i, "B").Value
        End Select
    Next i

    ' Kopieren von Zellen E6 bis E? aus aktA nach letzA entsprechend der Regel
    rowOffset = letzA.Cells(letzA.Rows.Count, "H").End(xlUp).Row - 1 ' Offset für das Einfügen in letzA
    For i = 6 To letzteZeile
        letzA.Cells(i + rowOffset, "H").Value = aktA.Cells(i, "E").Value
    Next i

End Sub