Alle Dateien - ein Tabellenblatt - Druckbereich als PDF speichern...

Frage:
Aus allen Excel Dateien eines Ordners (optional mit Unterordner) wird der Druckbereich eines bestimmten Tabellenblattes als PDF gespeichert. Der Name der PDF Datei ist der gleiche wie die Excel Datei. Wie geht das?

From all Excel files in a folder (optionally with subfolders), the print area of a particular worksheet is saved as a PDF. The name of the PDF file is the same as the Excel file. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Alle Dateien - ein Tabellenblatt als PDF speichern...[ZIP 180 KB]

Mögliche Probleme / Possible problems:
Zu beachten / Be observed...
Zu beachten / Be observed....

Option Explicit
' Suchmuster gegebenenfalls anpassen 
Const strEX As String = "*.xls*"
' Tabellenblattname gegebenenfalls anpassen 
Const strSheet As String = "Status"
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 08.01.2013 
' Purpose   : Alle Dateien eines Ordners - Ein Tabellenblatt als PDF... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien 
    ' strDir = ThisWorkbook.Path & "\" 
    ' Fester Ordner vorgegeben 
    strDir = "C:\Status\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.getfolder(strDir)
    'dirInfo objDir, strEX, True ' Mit Unterordner 
    dirInfo objDir, strEX ' Ohne Unterordner 
Fin:
    With Application
        ' Bei Bedarf 
        '.Goto (ThisWorkbook.Worksheets(1).Range("A1")), True 
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : dirInfo 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 08.01.2013 
' Purpose   : Rekursive Funktion alle Dateien... 
'-------------------------------------------------------------------------- 
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim wkbBook As Workbook
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName Then
            If varTMP.Name <> ThisWorkbook.Name Then
                If Left(varTMP.Name, 1) <> "~" Then
                    Set wkbBook = Workbooks.Open(varTMP.Path)
                        wkbBook.Worksheets.Add
                        With wkbBook.Worksheets(strSheet)
                            If .PageSetup.PrintArea <> "" Then
                                .Range(.PageSetup.PrintArea).Copy _
                                    wkbBook.Worksheets(1).Range("A1")
                            End If
                            Worksheets(1).ExportAsFixedFormat 0, _
                                ThisWorkbook.Path & _
                                Application.PathSeparator & _
                                Left(wkbBook.Name, _
                                (InStrRev(wkbBook.Name, ".") - 1)) _
                                , , , , , , False
                        End With
                    wkbBook.Close False
                    Set wkbBook = Nothing
                End If
            End If
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
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)...