Printing multiple workbooks into pdf

[o0omax]

Hello,

I want to print multiple excel files (around 100) from a specific folder to Pdf. Not the entire workbook should be pinted but one sheet (which has the same name in every excel file). As I have little knowledge of VBA and I failed at puzzling code together I want to ask for your help.

Would really appreciate it!

Kind regards

[anish.ms]

Try this

Option Explicit


Sub Save2PDF()


    Dim strDirContainingFiles As String, strFile As String, _
        strFilePath As String, xFolder As String
    Dim wbkSrc As Workbook
    Dim wksSrc As Worksheet, xWS As Worksheet
    Dim lngIdx As Long
    Dim t0     As Double
    Dim colFileNames As Collection
    Set colFileNames = New Collection
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        strDirContainingFiles = .SelectedItems(1) & "\"
    End With
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    strFile = Dir(strDirContainingFiles & "\*.xl*")
    Do While Len(strFile) > 0
        colFileNames.Add Item:=strFile
        strFile = Dir
    Loop
    
    If colFileNames.Count = 0 Then
        MsgBox "There are no excel files in this folder."
        Exit Sub
    Else
        MsgBox "There are " & colFileNames.Count & " excel files in this folder."
    End If
    
    t0 = CDbl(Now())
    
    For lngIdx = 1 To colFileNames.Count
        strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
        Set wbkSrc = Workbooks.Open(strFilePath)
        For Each xWS In wbkSrc.Sheets
            If xWS.Name = "o0omax" Then           '< change based on your Sheet name
                
                Set wksSrc = wbkSrc.Worksheets(xWS.Name)
                xFolder = strDirContainingFiles + "\" + wbkSrc.Name + ".pdf"
                wksSrc.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
                Exit For
            End If
        Next xWS
        wbkSrc.Close savechanges:=False
    Next lngIdx
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed!"
    
End Sub

[o0omax]

It seems do do sth. But after the window which shoewd how long it took, there wer no files created.

[anish.ms]

It seems do do sth. But after the window which shoewd how long it took, there wer no files created.

Did you change the sheet name with yours in the code

If xWS.Name = "o0omax" Then           '< change based on your Sheet name

[o0omax]

Yes I did change that, if I run the code step by step with F8 then the code seem to crash at this code

Set wbkSrc = Workbooks.Open(strFilePath)

[o0omax]

Try this

Option Explicit


Sub Save2PDF()


    Dim strDirContainingFiles As String, strFile As String, _
        strFilePath As String, xFolder As String
    Dim wbkSrc As Workbook
    Dim wksSrc As Worksheet, xWS As Worksheet
    Dim lngIdx As Long
    Dim t0     As Double
    Dim colFileNames As Collection
    Set colFileNames = New Collection
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        strDirContainingFiles = .SelectedItems(1) & "\"
    End With
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    strFile = Dir(strDirContainingFiles & "\*.xl*")
    Do While Len(strFile) > 0
        colFileNames.Add Item:=strFile
        strFile = Dir
    Loop
    
    If colFileNames.Count = 0 Then
        MsgBox "There are no excel files in this folder."
        Exit Sub
    Else
        MsgBox "There are " & colFileNames.Count & " excel files in this folder."
    End If
    
    t0 = CDbl(Now())
    
    For lngIdx = 1 To colFileNames.Count
        strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
        Set wbkSrc = Workbooks.Open(strFilePath)
        For Each xWS In wbkSrc.Sheets
            If xWS.Name = "o0omax" Then           '< change based on your Sheet name
                
                Set wksSrc = wbkSrc.Worksheets(xWS.Name)
                xFolder = strDirContainingFiles + "\" + wbkSrc.Name + ".pdf"
                wksSrc.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
                Exit For
            End If
        Next xWS
        wbkSrc.Close savechanges:=False
    Next lngIdx
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed!"
    
End Sub

IT DID WORK! Thanks!

Apparently the folder I chose had a file which didn´t work. Thanks a lot! Is there a way I can print all of those 100 Excel into one Powerpoint? Where one sheet from one excel has on slide?

You´re the king!

[anish.ms]

Try this
same code instead of exporting as pdf pasting into a power point as Enhanced Metafile

Option Explicit


Sub copy2powerpnt()


    Dim strDirContainingFiles As String, strFile As String, strFilePath As String, xFolder As String
    Dim wbkSrc As Workbook
    Dim wksSrc As Worksheet, xWS As Worksheet
    Dim lngIdx As Long
    Dim t0     As Double
    Dim c00    As Variant, c01 As Variant
    Dim colFileNames As Collection
    Set colFileNames = New Collection
    
    
    Dim rng    As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        strDirContainingFiles = .SelectedItems(1) & "\"
    End With
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
    End With
    
    strFile = Dir(strDirContainingFiles & "\*.xl*")
    Do While Len(strFile) > 0
        colFileNames.Add Item:=strFile
        strFile = Dir
    Loop
    
    If colFileNames.Count = 0 Then
        MsgBox "There are no excel files in this folder."
        Exit Sub
    Else
        MsgBox "There are " & colFileNames.Count & " excel files in this folder."
    End If
    
    t0 = CDbl(Now())
    
    On Error Resume Next
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    Err.Clear
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    On Error GoTo 0
    Set myPresentation = PowerPointApp.Presentations.Add
    
    For lngIdx = 1 To colFileNames.Count
        strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
        Set wbkSrc = Workbooks.Open(strFilePath)
        For Each xWS In wbkSrc.Sheets
            If xWS.Name = "o0omax" Then            '< change based on your Sheet name
                
                Set wksSrc = wbkSrc.Worksheets(xWS.Name)
                Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
                wksSrc.UsedRange.Copy
                mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
                Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
                myShape.Left = 66
                myShape.Top = 152
                
                '                xFolder = strDirContainingFiles + "\" + wbkSrc.Name + ".pdf"
                '                wksSrc.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
                Exit For
            End If
        Next xWS
        wbkSrc.Close savechanges:=False
    Next lngIdx
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed!"
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
End Sub

[o0omax]

How do I then close and save the Powerpoint in the same path the folder is?