Ergänzung zum Makro Modul kopieren

Public Sub Sigrid_NEU_BlattSpeichern()
Dim TBName$
Dim tan
tan = ActiveSheet.Name
TBName = ActiveSheet.Name
'ActiveSheet.Unprotect (getStrPasswort)
Dim WBName As String, varAntwortMsg
Do
WBName = InputBox(Chr(13) & Chr(13) & _
"JETZT  im blau makierten Feld Kunden-Name eingeben: " & Chr(13) & Chr(13) & _
_
"              NUR Namen, kein DOPPELPUNKT, kein Schrägstrich !", _
"Kunden-Namen für Datei >", tan & ".xls")
If Not sichererDateiname(WBName) Then
If MsgBox("Dateiname enthält ungültige Sonderzeichen." & Chr(10) & _
"Nochmal probieren?", vbYesNo) = vbNo Then Exit Sub
Else
Exit Do
End If
Loop
ActiveSheet.Range("D1") = WBName
If WBName = "" Then Exit Sub
ActiveSheet.Unprotect (getStrPasswort)
Worksheets(TBName).Copy
'--- so jetzt noch ins Verzeichnis speichern -------------
Dim Fs As Object, OrdNam As Variant, Ord As Byte, Pfad As String
Dim DateiNam As String
Dim aDatei As String
Dim strPath$
DateiNam = WBName & " " & "Rg.-Nr. " & ActiveSheet.Range("I23") & " - " & ActiveSheet.Range(" _
J23") & " " _                                                                   & ActiveSheet.Range("E23") & ".xls"
'Pfad
strPath = "C:\_Sigi\__Dokumente\__Rechnungen\"
With ActiveSheet                        'Tabelle anpassen
If IsDate(.Range("J18")) Then
If .Range("J18") > 0 Then
'Pfad Jahr
strPath = strPath & Year(.Range("J18").Value) & "\"
'Pfad Monat
strPath = strPath & Format(.Range("J18").Value, "MM  MMMM") & "\"
'Ordner erstellen sollte dieser nicht vorhanden sein
apiCreateFullPath strPath
'Pfad Dateiname
strPath = strPath & DateiNam         '''''''ActiveWorkbook.Name
'Prüfung ob vorhanden
If Dir(strPath, vbNormal)  "" Then
MsgBox "Kunden-Name " & DateiNam & Chr(13) & Chr(13) & _
"mit der Rg. - Nr. ist vorhanden !" & vbLf & vbLf & "Bitte ändern !"
' strPath = ActiveWorkbook.FullName
' On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Close ''True
' Kill strPath
' ActiveWindow.Close
Exit Sub                    ' ich eingesetzt
Else
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strPath, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
End If
End If
End If
End With
'- vorhandene button löschen -----------------------
'''' On Error Resume Next                         'raus 25.4.16
ActiveSheet.Shapes("CommandButton7").Delete
ActiveSheet.Shapes("CommandButton8").Delete      'zur Rechnungs-Auswahl
ActiveSheet.Shapes("CommandButton1").Delete     ' korrektur speichern
ActiveSheet.Shapes("CheckBox3").Delete          ' korrektur einschalten
''''' On Error GoTo 0
ActiveSheet.Application.ScreenUpdating = False
'----- jetzt schutz setzen --------------
Dim akw As String
akw = ActiveWorkbook.Name
Dim Password As String
Password = "wwpa"
Dim vbext_pp_none
Dim wb As Workbook, ok As Boolean, s As String
Set wb = Application.Workbooks(akw)
If ActiveSheet.Name = "Rechnung MG" Then
Call Arbeitsmappe_Makro_schreiben_Neu_MG
End If
End If
ActiveWorkbook.SaveAs Filename:=strPath, _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close True
Set wb = Nothing
'ActiveSheet.Unprotect (getStrPasswort)
''----- hier die Vorlage löschen -----------------------------------
ActiveSheet.Range("C11:C16").ClearContents                                 ' seite 1
If ActiveSheet.Name = "Rechnung1" Then
ActiveSheet.Unprotect (getStrPasswort)
Sheets("Rechnung1").CheckBox1.Value = False
ActiveSheet.Range("D1") = ThisWorkbook.Sheets("Rechnungs-Auswahl").Range("A46")
ActiveSheet.Range("C11").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPasswort
End If
ActiveSheet.Range("D1") = ThisWorkbook.Sheets("Rechnungs-Auswahl").Range("A46")
ActiveSheet.Range("C11").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPasswort
ActiveSheet.Range("D1") = ThisWorkbook.Sheets("Rechnungs-Auswahl").Range("A46")
ActiveSheet.Range("C11").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPasswort
End If
If ActiveSheet.Name = "Slozinskima" Then
ActiveSheet.Unprotect (getStrPasswort)
Sheets("Slozinskima").CheckBox1.Value = False
ActiveSheet.Range("D1") = ThisWorkbook.Sheets("Rechnungs-Auswahl").Range("A46")
ActiveSheet.Range("C11").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True, Password:=getStrPasswort
End If
ActiveSheet.Application.ScreenUpdating = True
End Sub