VBA: Speicher Button mit variablem Dateinamen

[MrHoef]

Hallo zusammen,

ich habe in einer Excel-Datei einen Button eingefügt, der mir nach Klick eine Datei nach einem Namen aus Zelle D24 unter einem definiertem Pfad abspeichert.
Falls die Zelle leer ist, taucht ein Hinweis auf.
Der Code hierzu lautet:

Code:

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
   ByVal DirPath As String) As Long

Public Sub Speichern()

If Cells(24, 4).Value = "" Then
MsgBox "CS-Meldungsnummer noch nicht eingetragen!!!"
Exit Sub
End If


   Dim strPath As String, strFile As String
   strFile = Range("D24").Text & ".xlsm"
   strPath = "S:\Dokumentenverwaltung\12_Auftragsablage\Servo\" & Format(Date, "yyyy") & "\" & Cells(24, 4).Text & "\"
   If CBool(MakeSureDirectoryPathExists(strPath)) Then
       ThisWorkbook.SaveAs Filename:=strPath & strFile, FileFormat:=52
   Else
       MsgBox "Fehler beim anlegen des Pfades: " & strPath
   End If
End Sub

Gibt es nun die Möglichkeit, wenn zB. in Zelle A1 und B1 ein "x" steht, die Datei bei Klick auf den Button unter einem anderen Dateinamen abzuspeichern!? (am Ende des Dateinamens noch _Stufe1.xlsm)

Ich benötige das ganze 4 mal für die folgenden Gegebenheiten:
A1 und B1 = "x" -> Dateiname Ende + _Stufe1.xlsm
A1 und B2 = "x" -> Dateiname Ende + _Stufe2.xlsm
A1 und B3 = "x" -> Dateiname Ende + _Stufe3.xlsm
A1 und B4 = "x" -> Dateiname Ende + _Stufe4.xlsm


Kann mir jemand helfen wie ich hier meinen Code umbauen muss!?
Experimentiere erst seit kurzem mit VBA und komme einfach nicht drauf...


Vielen Dank schon mal für jede Hilfe!
Liebe Grüße

[Steffl]

Hallo,

vielleicht so?

Code:

Public Sub Speichern()
    Dim strPath As String, strFile As String
    Dim lngCounter As Long


If Cells(24, 4).Value = "" Then
MsgBox "CS-Meldungsnummer noch nicht eingetragen!!!"
Exit Sub
End If


    strFile = Range("D24").Text & ".xlsm"
    strPath = "S:\Dokumentenverwaltung\12_Auftragsablage\Servo\" & Format(Date, "yyyy") & "\" & Cells(24, 4).Text & "\"
    If CBool(MakeSureDirectoryPathExists(strPath)) Then
        If Range("A1") = "x" And WorksheetFunction.CountIf(Range("B1:B4"), "x") Then
            ThisWorkbook.SaveAs filenname:=strPath & "Dateiname Ende_Stufe" & WorksheetFunction.Match("x", Range("B1:B4"), 0), FileFormat:=52
        Else
            ThisWorkbook.SaveAs Filename:=strPath & strFile, FileFormat:=52
        End If
    Else
        MsgBox "Fehler beim anlegen des Pfades: " & strPath
    End If
End Sub

[MrHoef]

  Test_Pumpencode_Speichern.xlsm (Größe: 19,75 KB / Downloads: 2)


Hallo Steffl und vielen Dank schonmal,

leider funktioniert der Code so nicht, und folgende Meldung taucht auf:

Fehler beim kompilieren:

Bekanntes Argument nicht gefunden

habe dir mal eine Beispieldatei angehängt vll. wird es damit ersichtlicher. (Der Code befindet sich in Modul 2)

Liebe Grüße

[Steffl]

Hallo,

schreibe anstatt filenname filename (war Tippfehler  :22: ).

[MrHoef]

Ach super! Funktioniert 1A, vielen vielen Dank dir!   :28: :28: :28:

[MrHoef]

Nochmal eine Frage zu diesem Code,

wie kann ich ihn abändern damit die Datei nicht automatisch ins angegebene Verzeichnis gespeichert wird,
sondern sich in diesem nur das Speichern unter Fenster öffnet und der Dateiname nur als Vorschlag dient und noch abgeändert werden kann?

Außerdem soll die Datei eine Pdf sein
Geht das so?


Viel Dank nochmal!

Code:

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
   ByVal DirPath As String) As Long

Public Sub Speichern()
   Dim strPath As String, strFile As String
   Dim lngCounter As Long




   strFile = Range("D11").Text & "_" & Format(Date, "yyyymmdd") & ".xlsm"
   strPath = "S:\Dokumentenverwaltung\12_Auftragsablage\Pumpen\" & Format(Date, "yyyy") & "\" & Cells(11, 4).Text & "\"
   If CBool(MakeSureDirectoryPathExists(strPath)) Then
       If Range("D14:D14").Value = "X" And Range("G14:G14").Value = "X" Then
           ThisWorkbook.SaveAs Filename:=strPath & Range("D11").Text & "_1Stufe" & "_" & Format(Date, "yyyymmdd"), FileFormat:=52
       ElseIf Range("D14:D14").Value = "X" And Range("G15:G15").Value = "X" Then
           ThisWorkbook.SaveAs Filename:=strPath & Range("D11").Text & "_2Stufe" & "_" & Format(Date, "yyyymmdd"), FileFormat:=52
       ElseIf Range("D14:D14").Value = "X" And Range("Q14:Q14").Value = "X" Then
           ThisWorkbook.SaveAs Filename:=strPath & Range("D11").Text & "_3Stufe" & "_" & Format(Date, "yyyymmdd"), FileFormat:=52
       ElseIf Range("D14:D14").Value = "X" And Range("Q15:Q15").Value = "X" Then
           ThisWorkbook.SaveAs Filename:=strPath & Range("D11").Text & "_4Stufe" & "_" & Format(Date, "yyyymmdd"), FileFormat:=52
       Else
           ThisWorkbook.SaveAs Filename:=strPath & strFile, FileFormat:=52
       End If
   Else
       MsgBox "Fehler beim anlegen des Pfades: " & strPath
   End If
End Sub

[Steffl]

Hallo,

wegen dem PDF: Bei der SaveAs-Methode kannst Du Pdf nicht als Fileformat auswählen, das geht so

PHP-Code:

           ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strFile 


jetzt nur für den Else-Teil, die anderen musst du anpassen. Bezüglich der anderen Geschichte: Keine Ahnung.

[MrHoef]

Hi Steffl,

habe mir folgenden Code abgeändert und er funktioniert so weit wie er soll,
jedoch lässt sich die .pdf-Datei anschließend nicht öffnen bzw. wird als falsches Dateiformat abgespeichert.
Wo liegt hier mein Fehler?

Gruß Sebbi

Code:

Sub Speichern_unter()

Dim Datei As String
Dim Verzeichnis As String
Dim SaveDummy As Variant


Verzeichnis = "U:\" 'Verzeichnis-Vorschlag
Datei = "00" & Range("G24") & ".pdf" 'Datei-Vorschlag

SaveDummy = SpeichernUnter(Verzeichnis & Datei)
If SaveDummy <> False Then ActiveWorkbook.SaveAs SaveDummy 'Es wurde im Dialog auf Speichern gedrückt

End Sub



Function SpeichernUnter(VorgabeName As String) As Variant

SpeichernUnter = Application.GetSaveAsFilename(InitialFileName:=VorgabeName, Filefilter:="PDF Dateien (*.pdf),*.pdf*", _
FilterIndex:=1, Title:="Speichern unter...", ButtonText:="speichern")

End Function

[Steffl]

Hallo,

ich zitier mich mal selber

wegen dem PDF: Bei der SaveAs-Methode kannst Du Pdf nicht als Fileformat auswählen, das geht so

PHP-Code:

           ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strFile 


[MrHoef]

Ok hab ich verstanden,
habe einen neuen einfacheren Code für die Funktion gefunden der soweit funktioniert,
allerdings weiß ich nicht wo ich hier einen Pfad angeben kann der dann als Speicherort vorgeschlagen wird.
Das ist das einzigste was mir jetzt noch fehlt.


Gruß Sebbi

Code:

Option Explicit

Sub saveAsPDF()
   ChDir "U:\"
   Dim X
   X = Application.GetSaveAsFilename(InitialFileName:=Range("K24").Text & ".pdf", _
        FileFilter:="PDF files, *.pdf", _
        Title:="Save PDF File")
   If TypeName(X) = "Boolean" Then
   Else
       ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
           Filename:=X, Quality:=xlQualityStandard, _
           IncludeDocProperties:=True, IgnorePrintAreas:=False, _
           OpenAfterPublish:=True
       End If
   End Sub