Makro per Makro entfernen

Sub großsavenundinternverschicken()
Dim offnen$, speichernintern$
Dim outl As Object, mail As Object
Set outl = CreateObject("outlook.application")
Set mail = outl.createitem(olmailitem)
offnen = Range("b87").Value
speichernintern = Range("b88").Value
Application.ScreenUpdating = False
Workbooks.Open offnen & Date - 1 & ".xls", UpdateLinks:=0
ActiveWorkbook.SaveAs Filename:=speichernintern & Date - 1 & "i" & ".xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = False
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
With ActiveWorkbook.VBProject
.VBComponents.Remove .VBComponents("Modul1")
.VBComponents.Remove .VBComponents("UserForm1")
End With
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Sheets("Beendet").Select
ActiveWindow.SelectedSheets.Delete
Sheets("nach WC").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Vorlage KWs").Select
ActiveWindow.SelectedSheets.Delete
'Sheets(Array("nach WC", "Beendet", "Vorlage KWs", "2", "3", "4", "5", "7", "8", "9", "10", "11" _
, "12", "13", "16", "17", "18", _
'        "20", "21", "23")).Select
'ActiveWindow.SelectedSheets.Delete
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
For i = 1 To Worksheets.Count
Sheets(i).Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
On Error Resume Next
ActiveSheet.Shapes("CB_1").Select
Selection.Delete
Next i
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Sheets("Gesamt").Select
Range("A1").Select
ActiveWorkbook.Save
Application.DisplayAlerts = True
ActiveWorkbook.Close
Sheets("Atlas").Activate
Application.ScreenUpdating = True
With mail
.Subject = "Großaktion Stand " & Date - 1
.To = "Großaktion"
.attachments.Add speichernintern & Date - 1 & "i" & ".xls"
.display
End With
Set outl = Nothing
Set mail = Nothing
End Sub