Habe eine Spalte helöscht / Problem mit Makro

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
'Inhalt Spalte B nach tabelle1 kopieren
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 7)
End With
With Sheets("Tabelle3")
'Inhalt aus Spalte E kopieren
.Range(.Cells(von, 5), .Cells(bis, 5)).Copy
End With
'In Spalte H einfügen
.Cells(zt1, 8).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If bis > 1 Then
'Spalte A bis C durch kopieren auffüllen
.Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
End If
Application.CutCopyMode = False
With Sheets("Tabelle1")
Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy _
Destination:=.Range(Cells(zt1, 4), Cells(zt1 + bis - von, 4))
Application.CutCopyMode = False
End With
'         Stop
For Each c In Range(.Cells(zt1, 7), .Cells(zt1 + bis - von, 7))
If c.Hyperlinks.Count > 0 Then
a = Split(c.Hyperlinks(1).Address, "/")
'              For i = 1 To UBound(a): MsgBox a(i): Next
c.Offset(0, -1).Value = a(UBound(a) - 1)
End If
Next
'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
.Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
key1:=.Range("E1"), Order1:=xlAscending, _
key2:=.Range("H1"), Order2:=xlDescending, Header:=xlNo
End With
With Sheets("Tabelle2")
'Daten in Spalten A bis C löschen
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With Sheets("Tabelle3")
'Daten in Spalten A bis D  löschen
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
Application.ScreenUpdating = True
End Sub

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
'Inhalt Spalte B nach tabelle1 kopieren
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 6)
End With
With Sheets("Tabelle3")
'Inhalt aus Spalte E kopieren
.Range(.Cells(von, 5), .Cells(bis, 7)).Copy
End With
'In Spalte H einfügen
.Cells(zt1, 7).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If bis > 1 Then
'Spalte A bis C durch kopieren auffüllen
.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).Copy _
Sheets("Tabelle1").Range("D" & zt1 + bis - von)
'         Stop
For Each c In Range(.Cells(zt1, 6), .Cells(zt1 + bis - von + 1, 5))
If c.Hyperlinks.Count > 0 Then
a = Split(c.Hyperlinks(1).Address, "/")
'              For i = 1 To UBound(a): MsgBox a(i): Next
c.Offset(0, -1).Value = a(UBound(a) - 1)
End If
Next
'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
.Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
key1:=.Range("D1"), Order1:=xlAscending, _
key2:=.Range("G1"), Order2:=xlDescending, Header:=xlNo
End With
With Sheets("Tabelle2")
'Daten in Spalten A bis C löschen
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With Sheets("Tabelle3")
'Daten in Spalten A bis D  löschen
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
Application.ScreenUpdating = True
End Sub