Makierung aufheben

Private Sub CommandButton1_Click()
Dim Verz As String, fn
Verz = "c:\Modul\Projekte\"
fn = Application.GetSaveAsFilename(Verz, "Excel-Arbeitsmappe (*.xls),*.xls", , "Datei speichern")
If fn = False Then Exit Sub 'Abbruch des Menüpunktes "Speichern unter"
'Kopie einer Datei ohne Formeln mit Format mur Druckbereich, Register nicht geschützt
Dim InI As Integer
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = 3
With ThisWorkbook
' Datei mit Code
ActiveWorkbook.SaveAs Filename:=fn  ' neue Datei Workbooks.Add
If fn = False Then Exit Sub
For InI = .Worksheets.Count To 1 Step -1     ' Anzahl Register in ThisWorkbook
If .Worksheets(InI).PageSetup.PrintArea <> "" Then
Sheets.Add
.Worksheets(InI).Range("Druckbereich").Copy
With ActiveWorkbook.ActiveSheet.Range("A1")
.PasteSpecial Paste:=xlPasteValues      ' Werte
.PasteSpecial Paste:=xlFormats          ' Formate
.PasteSpecial Paste:=8                  ' Splatenbreite
End With
ActiveWorkbook.ActiveSheet.Name = .Worksheets(InI).Name
End If
Next InI
Application.CutCopyMode = False         'Zwischenspeicher löschen
Application.DisplayAlerts = False
Worksheets(ActiveWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
ActiveWorkbook.Close True
MsgBox "Die Position wurde im Verzeichnis: " & fn & " gespeichert", , "Speichern unter..."
End With
End Sub