Makro soll andere Zellen kopieren

Sheets("Tabelle1").Activate
Application.ScreenUpdating = True
With Cells(Rows.Count, 8).End(xlUp)
.Resize(1, 6).Copy
.Activate
End With

Sub Makro3()
' Makro3 Makro
' Tastenkombination: Strg+i
Dim zt1&, von&, bis As Long
Dim Grafiken As Shape
Dim c As Range, a As Variant
Application.ScreenUpdating = False
With Sheets("Tabelle1")
zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
von = 1
With Sheets("Tabelle2")
bis = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 6)
End With
With Sheets("Tabelle3")
.Range(.Cells(von, 5), .Cells(bis, 5)).Copy
End With
.Cells(zt1, 7).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If bis > 1 Then
.Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
End If
Application.CutCopyMode = False
Sheets("Tabelle1").Range("D" & zt1 - 1 & ":E" & zt1 - 1).Copy _
Sheets("Tabelle1").Range("D" & zt1 & ":E" & zt1 + bis - von)
For Each c In Range(.Cells(zt1, 6), .Cells(zt1 + bis - von + 1, 6))
If c.Hyperlinks.Count > 0 Then
a = Split(c.Hyperlinks(1).Address, "/")
c.Offset(0, -1).Value = a(UBound(a) - 1)
End If
Next
.Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 14)).Sort _
key1:=.Range("D1"), Order1:=xlAscending, _
key2:=.Range("G1"), Order2:=xlDescending, Header:=xlNo
End With
With Sheets("Tabelle2")
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With Sheets("Tabelle3")
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
Sheets("Tabelle1").Activate
Application.ScreenUpdating = True
With Cells(Rows.Count, 8).End(xlUp)
.Resize(1, 6).Copy
.Activate
End With
End Sub