Blatt Speichern

Private Sub cmdFreigeben_Click()
Dim kopierKW%, zeileLinie%
Dim datName$, extName$, ergName$, zielPfad$, altPfad$
Dim Frage
zielPfad = "F:\Vetropack\"
' Abfrage der Woche
Do
kopierKW = Application.InputBox("Welches Kalenderwochen-Blatt wollen Sie kopieren?", _
"Kalenderwochen-Blatt", KW, , , , 1)
If kopierKW = 0 Then Exit Sub
Loop While kopierKW  54
' eventuellen Blattschutz aufheben
On Error Resume Next
Worksheets("WoMat").Unprotect
Application.ScreenUpdating = False
' Suchen nach der Zeilennummer lt. Kalenderwoche
With Sheets("WoMat")
zeileLinie = 0
For n = 2 To 1978 Step 38
If .Cells(n, 10).Value = kopierKW Then
zeileLinie = n - 1
Exit For
End If
Next n
If zeileLinie = 0 Then
MsgBox "Kalenderwoche " & KW & " nicht gefunden!"
Exit Sub
End If
' Kopieren in das Tabellenblatt 'Wochenblatt'
.Range("A" & zeileLinie - 1 & ":AX" & zeileLinie + 36).Copy _
Destination:=Sheets("Wochenblatt").Range("A1")
End With
'Laufwerk und Ordner von dieser Arbeitsmappe
altPfad = ThisWorkbook.Path
'Laufwerk und Ordner als Vorgabe setzen
ChDrive "\": ChDir zielPfad
datName = "WoMat" & " " & "KW " & CStr(kopierKW) & "-" & Format(Date, "YYYY") & "": extName  _
= ".xls"
'Das Dialogfenster mit Vorgabedatei
ergName = Application.GetSaveAsFilename _
(datName & extName, "Micrsoft Excel-Dateien (*.xls),*.xls")
' Auswerten des Dateinamen
Select Case ergName
Case "", False: Exit Sub
Case vbYes
If Dir(ergName)  "" Then
Frage = MsgBox("Die Datei " & ergName & " existiert schon! Überschreiben?", vbYesNo) _
If Frage = vbNo Then Exit Sub
End If
End Select
'Speichervorgang
Worksheets("Wochenblatt").Copy
ActiveWorkbook.SaveAs ergName 'zielPfad & ergName
ActiveWorkbook.Close savechanges:=False
'Laufwerk und Ordner rücksetzen
ChDrive "\": ChDir altPfad & "\"
Worksheets("WoMat").Protect Password:="", Contents:=True, UserInterfaceOnly:=True
Application.ScreenUpdating = True
End Sub