Variabler Speicherort per VBA

Hallo liebes Forum,
ich habe mir ein Code zusammengestellt der Super Funktioniert.
Beim Speichern Unter wird mit der Name von "N18" unter den angegebenen pfaden abgespeichert.
Ist es möglich das wenn der Name in "N18" mit "A" anfängt, dass ein anderes Pfad benutzt wird als sonst ?
Das ist der Auslöser Makro

Sub Seichern_Makro()
On Error GoTo Fehler
If MsgBox("Achtung!!!" & vbNewLine & "Excel schließt sich nach dem Speichern, soll fortgefahren  _
werden ?", vbYesNo + vbQuestion, _
"Achtung!") = vbYes Then GoTo Fortfahren Else GoTo EndeMakro
Fortfahren:
Call Speichern_unter_einfach
Call aktivesBlattToPdf
Application.DisplayAlerts = False
ActiveWorkbook.Close 'excel schließen
Application.Quit
Application.DisplayAlerts = True
GoTo EndeMakro
Exit Sub
Fehler:
MsgBox "Fehler !!!" & vbNewLine & "Es wurde keine Kundennummer zugeordnet." & vbNewLine &  _
vbNewLine & _
"Oder die Ordnerpfade stimmen nicht mehr.", vbQuestion, "Achtung!"
EndeMakro:
End Sub

Und dies sind die beiden CALLS

Sub aktivesBlattToPdf()
'Const DateiPfad = "C:\Users\Schindler Holzbau\Google Drive\Markus Schindler\Geschäftlich\ _
Kunden Daten 2017\001Ausgangsrechnungen\PDF-Ausgangsrechnungen\"
Const DateiPfad = "E:\Meine Dokumente\VBA Tom\"
Dim DateiName As String
DateiName = DateiPfad & Range("N18") & ".pdf" 'aus dem Range N18 wird der Name gebildet
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
DateiName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End Sub

Sub Speichern_unter_einfach()
'hiermit wir nur die aktive Tabellenmappe gespeichert
Dim strVerzeichnis As String
Dim varDateiname As Variant
'strVerzeichnis = "C:\Users\Schindler Holzbau\Dropbox\Markus Schindler\Geschäftlich\Kunden  _
Daten 2017\001Ausgangsrechnungen\Originalausgansgsrechnungen\"
strVerzeichnis = "E:\Meine Dokumente\VBA Tom\"
varDateiname = Application.GetSaveAsFilename(InitialFileName:=strVerzeichnis & Range("N18") _
& ".xlsx", _
FileFilter:="Microsoft Excel-Dateien (*.xlsx), *.xlsx") 'aus dem Range N18 wird der  _
Name gebildet
Application.DisplayAlerts = False 'Warnungen und Meldungen Ignorieren
If TypeName(varDateiname) = "String" Then 'Wenn Dateiname angegeben wurde und mit OK bestä _
tigt
ActiveSheet.Copy    'Kopiert nur das aktuelle Blatt in eine neue Mappe
ActiveWorkbook.SaveAs varDateiname 'neue Mappe unter eingegebenenm Namen speichern
ActiveWorkbook.Close 'Neue Mappe wieder schliessen
End If
'''' macht bei Excel 2010 Probleme (Tom)
'Select Case varDateiname
'Case False
'Exit Sub
'Case Else
'ThisWorkbook.SaveAs Filename:=varDateiname
'End Select
Application.DisplayAlerts = True 'Warnungen und Meldungen aktivieren
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Manuela,
teste mal:

Option Explicit

Public Sub Seichern_Makro()
    Dim strFilename As String, strVerzeichnis As String
    On Error GoTo Fehler
    If MsgBox("Achtung!!!" & vbNewLine & "Excel schließt sich nach dem Speichern, " & _
        "soll fortgefahren werden ?", vbYesNo Or vbQuestion, "Achtung!") = vbYes Then

        strFilename = Trim$(Range("N18").Value)

        If UCase$(Left$(strFilename, 1)) = "A" Then
            strVerzeichnis = "E:\Meine Dokumente\VBA Tom\"
        Else
            strVerzeichnis = "E:\Anderer Ordner\Anderer Unterordner\"
        End If

        strVerzeichnis = strVerzeichnis & strFilename

        Call Speichern_unter_einfach(strVerzeichnis)
        Call aktivesBlattToPdf(strVerzeichnis)
        Application.DisplayAlerts = False
        ActiveWorkbook.Close
        Application.Quit
        Application.DisplayAlerts = True
    End If
    Exit Sub
    Fehler:
    MsgBox "Fehler !!!" & vbNewLine & "Es wurde keine Kundennummer zugeordnet." & vbNewLine & _
        vbNewLine & "Oder die Ordnerpfade stimmen nicht mehr.", vbQuestion, "Achtung!"
End Sub

Private Sub Speichern_unter_einfach(ByVal strVerzeichnis As String)

    Dim varDateiname As Variant

    strVerzeichnis = strVerzeichnis & ".xlsx"

    varDateiname = Application.GetSaveAsFilename(InitialFileName:=strVerzeichnis, _
        FileFilter:="Microsoft Excel-Dateien (*.xlsx), *.xlsx")

    If VarType(varDateiname) = vbString Then
        Application.DisplayAlerts = False
        ActiveSheet.Copy
        ActiveWorkbook.Close SaveChanges:=True, Filename:=varDateiname
        Application.DisplayAlerts = True
    End If
End Sub

Private Sub aktivesBlattToPdf(ByVal strVerzeichnis As String)
    strVerzeichnis = strVerzeichnis & ".pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strVerzeichnis, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread