Gem sheet med macroer intakt

Sub kopierWB()
'Gemmer denne projektmappes navn i variablen navn
navn = ThisWorkbook.Name

'Åbner SaveAs dialog hvor nyt navn er forvalgt (test2.xlsm) ret sti og filnavn til ønsket
Application.Dialogs(xlDialogSaveAs).Show arg1:="C:\Users\Poul\Desktop\test2.xlsm"
'Sti og filnavn kan ændres igen i dialogen der dukker op

'Tester om der gemmes eller klikkes cancel.
'Hvis der gemmes, så slettes alle ark untaget Ark2
If navn <> ThisWorkbook.Name Then
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
If sh.Name <> "Ark2" Then sh.Delete '(ret til aktuel ark som skal beholdes)
Next
Application.DisplayAlerts = True

'Filen gemmes igen nu kun med valgt ark
ActiveWorkbook.Save

End If
End Sub