Hier der Code
29.07.2019 20:06:56
sigrid
Hallo zusammen,
hier der Code.
Public Sub NEU_BlattSpeichern()
Dim TBName$
Dim tan
tan = ActiveSheet.Name
TBName = ActiveSheet.Name
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 & ".xlsm")
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
MsgBox "Neuer Dateiname: " & WBName
ActiveSheet.Range("D1") = WBName
If WBName = "" Then Exit Sub
'--- 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") & ".xlsm"
strPath = "C:\_Werkstatt\__Möbel\__Rechnungen_gedruckt\"
With ActiveSheet
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
strPath = strPath & DateiNam
'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
' ActiveWorkbook.SaveCopyAs Filename:=strPath 'klappt auch nicht
ActiveWorkbook.SaveCopyAs strPath
Call Sheets_löschen
Exit Sub
' wb.Sheets("Rechnungs").Delete
' wb.Save
' wb.Close
End If
End If
End If
End With
End Sub
wie gesagt, gespeichert wird richtig allerdings werden die Sheets nur im Orginal und nicht in
der Copy gelöscht.
gruß sigrid