Probleme mit Code

Sub BlattKopieren()
Dim strPath As String
Dim strName As String
Dim strWert As String
Dim shp As Shape
strPath = "D:\Excel\Sport\"         'Pfad
strName = ActiveSheet.Name          'Tabellenname
strWert = ActiveSheet.Range("A2")   'Dateiname - zusatz
Application.ScreenUpdating = False
ActiveSheet.Copy
With ActiveWorkbook
For Each shp In Sheets(1).Shapes    'Schaltflächen entfernen
shp.Delete
Next
With .VBProject.VBComponents(.VBProject.VBComponents(2).CodeModule).CodeModule
.DeleteLines 1, .CountOfLines
End With
.Sheets(1).Cells.Locked = True  'Zellen sperren
.Sheets(1).Protect "test"       'Blattschutz setzen - Passwort anpassen
.SaveAs strPath & strName & " " & Format(Date, "dd mm yy") & " " & _
strWert & ".xls"
.Close
End With
ActiveWindow.SelectedSheets.Visible = False <<<<<<< Hier bleibt der Code stehen
Worksheets("Start").Activate
UserForm1.Show
Application.ScreenUpdating = True
End Sub