AW: KW mit Buchstaben kopieren
24.11.2006 13:54:54
Heinz
Hallo Firmus
Bin leider erst heute dazugekommen um zu Antworten
Habe nun den ganzen Code eingefügt.
Ich hoffe Du kannst mir Bitte weiterhelfen.
Es sollte so wie in Code KW52 das ich dann händisch in der Msg Box ein a,b,c usw. einfügen kann.
Danke und Gruß Heinz
' Einzelner Abschnitt aus WoMat in eigene Datei Kopieren und
' in Ordner unter frei wählbarem Namen speichern
Private Sub cmdFreigeben_Click()
Dim kopierKW%, zeileLinie%
Dim datName$, extName$, ergName$, zielPfad$, altPfad$
Dim Frage
zielPfad = "F:\Test\"
' 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 < 1 Or 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 = "KW " & CStr(kopierKW) & "": 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