Etwa so:

Sub Inhalt_kopieren()
Dim srcZeile As Long
Dim trgZeile As Long
Dim trgWS As Excel.Worksheet
Dim srcLetzteZeile As Long

'WICHTIG: Ich lasse die Kopie jeweils in Zeile 2 starten, da ich die Spaltenüberschriften nicht alle kenne
'und somit auch nicht kopieren oder erstellen kann. Das mußt Du selber einfügen

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Tabelle1").Activate

Set trgWS = ActiveSheet.Copy(After:=Sheets(Worksheets.Count)): DoEvents
trgWS.Name = "Tabelle" & Worksheets.Count

With trgWS
'Spaltenüberschriften erstellen
'    .Cells(1, 1) = "abc"
'    .Cells(1, 2) = "def"
'   ..........
End With

trgZeile = 2
With ThisWorkbook.Sheets("Tabelle1")
    srcLetzteZeile = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    For srcZeile = 2 To srcLetzteZeile
        trgWS.Cells(trgZeile, 3) = .Cells(srcZeile, 1)
        trgWS.Cells(trgZeile, 14) = .Cells(srcZeile, 2)
        trgWS.Cells(trgZeile, 6) = .Cells(srcZeile, 3)
        trgWS.Cells(trgZeile, 8) = .Cells(srcZeile, 4)
        trgWS.Cells(trgZeile, 7) = .Cells(srcZeile, 5)
        trgWS.Cells(trgZeile, 25) = .Cells(srcZeile, 6)
        trgWS.Cells(trgZeile, 26) = .Cells(srcZeile, 7)
        trgWS.Cells(trgZeile, 29) = .Cells(srcZeile, 8)
        trgWS.Cells(trgZeile, 24) = .Cells(srcZeile, 9)
        trgWS.Cells(trgZeile, 1) = .Cells(srcZeile, 10)
        trgWS.Cells(trgZeile, 2) = .Cells(srcZeile, 10)
        trgWS.Cells(trgZeile, 17) = .Cells(srcZeile, 11)
        trgWS.Cells(trgZeile, 18) = .Cells(srcZeile, 12)
        trgWS.Cells(trgZeile, 4) = .Cells(srcZeile, 13)
        trgZeile = trgZeile + 1
    Next srcZeile
     
End With
Set trgWS = Nothing
Application.ScreenUpdating = True
     
End Sub

Hoffe ich habe Dich richtig verstanden!

Severus