Grundsätzlich immer zusätzlich als PDF speichern...

Frage: Eine Exceldatei soll grundsätzlich immer zusätzlich als PDF in einem bestimmten Ordner gespeichert werden. Ist der Ordner nicht vorhanden soll er angelegt werden. Ist die PDF Datei vorhanden wird nachgefragt, ob sie überschrieben werden soll oder nicht.

An Excel file will basically always be additionally saved as a PDF in a specific folder. If the folder does not exist it will be created. If the PDF file is present will be asked if they want to overwrite it or not.

Hier noch eine Beispieldatei / Here's a sample file:
Grundsätzlich immer zusätzlich als PDF speichern...[XLS 70 KB]

Datei muss einmal gespeichert werden, NICHT nur aus dem Browser öffnen, denn dann ist sie schreibgeschützt.

File must be saved once, NOT only open from the browser, because then it is read only.

Code gehört in "DieseArbeitsmappe" / Code belongs in a "ThisWorkbook":

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
' Pfad für die PDF-Datei MIT abschliessendem Backslash 
Const strPDFPath As String = "C:\Temp\"
'-------------------------------------------------------------------------- 
' Module    : ThisWorkbook 
' Procedure : Workbook_BeforeSave 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 16.01.2013 
' Purpose   : Always save as PDF in particular folder... 
'-------------------------------------------------------------------------- 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    With ThisWorkbook
        If Dir(strPDFPath & fncEXT(.Name) & ".pdf") <> "" Then
            If MsgBox("Überschreiben?", vbYesNo, "Frage") = vbYes Then
                .ExportAsFixedFormat 0, strPDFPath & "\" & fncEXT(.Name)
            End If
        Else
            MakeSureDirectoryPathExists (strPDFPath)
            .ExportAsFixedFormat 0, strPDFPath & "\" & fncEXT(.Name)
        End If
        Application.Run ("Module1.Main")
    End With
Fin:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Function fncEXT(ByVal strName As String) As String
    fncEXT = Mid(strName, 1, InStr(strName, ".") - 1)
End Function

Code gehört in ein Modul (Module1) / Code belongs in a module (Module1):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 16.01.2013 
' Purpose   : Ausblenden Druckvorschaulinien. Hide print preview lines... 
'-------------------------------------------------------------------------- 
Private Sub Main()
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        ' Die Druckvorschaulinien ausblenden 
        wksSheet.DisplayAutomaticPageBreaks = False
    Next wksSheet
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...