Sub Knopf()
Dim oWsS As Worksheet, oWsT As Worksheet
Dim rngA As Range, rngD As Range, rngF As Range
Dim rngT As Range, c As Range
Dim x As Long
If Workbooks.Count = 1 Then
Call MsgBox("Zielmappe öffnen", vbExclamation)
Exit Sub
End If
Set oWsS = ThisWorkbook.Sheets("Tabelle1")
Set oWsT = Workbooks(2).Sheets("Tabelle1")
With oWsS
Set rngA = Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set rngD = .Cells(6, 4).Resize(rngA.Cells.Count)
Set rngF = .Cells(17, 6).Resize(rngA.Cells.Count)
End With
Set rngT = oWsT.Cells(6, 1)
For x = 1 To rngA.Cells.Count
If MsgBox(rngA.Cells(x).Address(0, 0) & " kopieren", vbYesNo) <> vbYes Then Exit For
rngA.Cells(x).Copy rngT
rngD.Cells(x).Copy rngT.Offset(, 1)
rngF.Cells(x).Copy rngT.Offset(, 2)
Set rngT = rngT.Offset(1)
Next x
oWsS.Copy After:=oWsT.Parent.Sheets(oWsT.Parent.Sheets.Count)
On Error Resume Next
oWsT.Parent.Sheets(oWsT.Parent.Sheets.Count).Name = oWsS.Cells(2, 8).Value
End Sub