VBA: Dateinamen erzeugen, Ordner selektieren
04.11.2005 12:06:32
der
und wieder habe ich die Ehre Euch eine Frage zu VBA zu stellen. Ich bastel ja seit geraumer Zeit an einer Tabelle zur Zeiterfassung, und konnte bisher durch Eure Hilfe schon einiges realisieren. :-)
Nun habe ich ein neues Problem, bei dem mir auch die Filfe-Funktion leider nciht weiterhelfen kann: In der geöffneten Arbeitsmappe sollen die sichtbaren Arbeitsblätter in einer neuen Datei gespeichert werden. Dieser Teil, also das "auswählen" der sichtbaren Blätter funktioniert einwandfrei.
Was mir jetzt ein Problem bereitet ist folgendes: Ich würde gerne eine DialogBox öffnen, in welcher nur der Speicherort ausgesucht wird, nicht jedoch der Dateiname, dieser wird im oberen Teil des Makros automatisch generiert.
Schön wäre es, wenn ein FileDialog(msoFileDialogFolderPicker) oder vergleichbares geöffnet werden würde.
Das Makro habe ich zum Verständnis hier nachstehend eingefügt. Die Zeilen welche mit "'X" beginnen sind die, die mir Probleme bereiten.
'Speichern unter
Private Sub CommandButtonSTORE_Click()
Dim strDateiname As String
Dim varRueckgabeSTR As Variant
Dim wkssheets() As String
Dim intcounter As Integer
Dim Name As String
Dim Datum1 As Date
Dim Datum2 As Date
intcounter = 0
' Worksheets("Montag").Range("U8:U8").NumberFormat = "yyyy/mm/dd"
Datum1 = Worksheets("Montag").Range("U8:U8")
Datum2 = Worksheets("Montag").Range("U8:U8") + 6
Name = Worksheets("Montag").Range("F8:F8")
strDateiname = Name & " " & Datum1 & "-" & Datum2
'X 'strDateiname = Application.InputBox("Bitte geben Sie den Dateinamen an:", "Speichern unter", _
'X strDateiname, Type:=2)
If strDateiname = "" Then Exit Sub
If VarType(strDateiname) = vbFalse Then
If strDateiname = False Then Exit Sub
Else
Application.ScreenUpdating = False
If Worksheets("Montag").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Montag"
intcounter = intcounter + 1
End If
If Worksheets("Dienstag").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Dienstag"
intcounter = intcounter + 1
End If
If Worksheets("Mittwoch").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Mittwoch"
intcounter = intcounter + 1
End If
If Worksheets("Donnerstag").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Donnerstag"
intcounter = intcounter + 1
End If
If Worksheets("Freitag").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Freitag"
intcounter = intcounter + 1
End If
If Worksheets("Samstag").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Samstag"
intcounter = intcounter + 1
End If
If Worksheets("Sonntag").Visible = True Then
ReDim Preserve wkssheets(intcounter)
wkssheets(intcounter) = "Sonntag"
intcounter = intcounter + 1
End If
Application.ScreenUpdating = True
Sheets(wkssheets).Copy
'X ' ActiveWorkbook.SaveAs("F:\Kannegiesser\Abrechnungen\Tagesberichte01\" & strDateiname & ".xls")
'X 'With Application.FileDialog(msoFileDialogFolderPicker)
'X With Application.GetSaveAsFilename(strDateiname, )
'X
'X .Show
'X .Value = strDateiname
'X
'X
'X End With
End If
ActiveWorkbook.Close
End Sub
Wie immer an dieser Stelle schon einmal vielen Dank für's anschauen!
mfg, Dan