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?