Save all Sheets to the right of active sheet as PDF

T

thedoccontroller

Board Regular
Joined
Dec 15, 2015
Messages
82
Okay so here goes...

Sheet1 ("Instructions") has the root file folder path in cell A52. Cell H10 (actually a range H10:J11 merged) has a string that is part of the name of a subfolder in that root. So I need to search the root (A52) for the folder containing the string (H10) and then save all sheets to the right of (excluding) the "Instructions" sheet, as a PDF. Ive dug quite a bit and can't piece it together. Thanks in advance.
Screenshot 2021-09-28 140033.png
 

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
Sort by date Sort by votes
You didn't say what the PDF file name should be. Try macro, which creates "Sheets.pdf".
VBA Code: 
Public Sub Save_Sheets_As_PDF()

    Dim saveInFolder As String
    Dim PDFfile As String
    Dim currentSheet As Worksheet
    Dim i As Long
    Dim replaceSelected As Boolean
    
    With ActiveWorkbook
    
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
    
        If saveInFolder <> "" Then
        
            PDFfile = saveInFolder & "Sheets.pdf"
    
            Set currentSheet = .ActiveSheet
            replaceSelected = True
            For i = .ActiveSheet.Index + 1 To .Sheets.Count
                .Sheets(i).Select replaceSelected
                replaceSelected = False
            Next
            
            .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfile, _
                Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            currentSheet.Select True
            
            MsgBox "Created " & PDFfile, vbInformation
            
        Else
        
            MsgBox "Partial subfolder name '" & .ActiveSheet.Range("H10").Value & "' not found in root folder " & .ActiveSheet.Range("A52").Value, vbExclamation
            
        End If
        
    End With
    
End Sub


'Breadth-first folder traverse looking for partial subfolder name starting at specified folder

Private Function Find_Subfolder(folderPath As String, findPartialSubfolderName As String) As String

    Static FSO As FileSystemObject
    Dim FSfolder As folder, FSsubfolder As folder
    
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set FSfolder = FSO.GetFolder(folderPath)
     
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If InStr(1, FSsubfolder.Path, findPartialSubfolderName, vbTextCompare) Then
            Find_Subfolder = FSsubfolder.Path & "\"
            Exit For
        End If
    Next
    
    If Find_Subfolder = "" Then
        For Each FSsubfolder In FSfolder.subfolders
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, findPartialSubfolderName)
            If Find_Subfolder <> "" Then
                Exit For
            End If
        Next
    End If
    
End Function
 
Upvote 0
Solution
John_w said:
You didn't say what the PDF file name should be. Try macro, which creates "Sheets.pdf".
VBA Code: 
Public Sub Save_Sheets_As_PDF()

    Dim saveInFolder As String
    Dim PDFfile As String
    Dim currentSheet As Worksheet
    Dim i As Long
    Dim replaceSelected As Boolean
   
    With ActiveWorkbook
   
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
   
        If saveInFolder <> "" Then
       
            PDFfile = saveInFolder & "Sheets.pdf"
   
            Set currentSheet = .ActiveSheet
            replaceSelected = True
            For i = .ActiveSheet.Index + 1 To .Sheets.Count
                .Sheets(i).Select replaceSelected
                replaceSelected = False
            Next
           
            .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfile, _
                Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            currentSheet.Select True
           
            MsgBox "Created " & PDFfile, vbInformation
           
        Else
       
            MsgBox "Partial subfolder name '" & .ActiveSheet.Range("H10").Value & "' not found in root folder " & .ActiveSheet.Range("A52").Value, vbExclamation
           
        End If
       
    End With
   
End Sub


'Breadth-first folder traverse looking for partial subfolder name starting at specified folder

Private Function Find_Subfolder(folderPath As String, findPartialSubfolderName As String) As String

    Static FSO As FileSystemObject
    Dim FSfolder As folder, FSsubfolder As folder
   
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Set FSfolder = FSO.GetFolder(folderPath)
    
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If InStr(1, FSsubfolder.Path, findPartialSubfolderName, vbTextCompare) Then
            Find_Subfolder = FSsubfolder.Path & "\"
            Exit For
        End If
    Next
   
    If Find_Subfolder = "" Then
        For Each FSsubfolder In FSfolder.subfolders
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, findPartialSubfolderName)
            If Find_Subfolder <> "" Then
                Exit For
            End If
        Next
    End If
   
End Function
Click to expand...
Sorry for the slow response. We had a Production emergency this morning and I've been in meetings all day. Let me look at these in the morning, and I'll let you know how it works. Thank you sooooo much for getting into this for me.
 
Upvote 0
John_w said:
You didn't say what the PDF file name should be. Try macro, which creates "Sheets.pdf".
VBA Code: 
Public Sub Save_Sheets_As_PDF()

    Dim saveInFolder As String
    Dim PDFfile As String
    Dim currentSheet As Worksheet
    Dim i As Long
    Dim replaceSelected As Boolean
   
    With ActiveWorkbook
   
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
   
        If saveInFolder <> "" Then
       
            PDFfile = saveInFolder & "Sheets.pdf"
   
            Set currentSheet = .ActiveSheet
            replaceSelected = True
            For i = .ActiveSheet.Index + 1 To .Sheets.Count
                .Sheets(i).Select replaceSelected
                replaceSelected = False
            Next
           
            .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfile, _
                Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            currentSheet.Select True
           
            MsgBox "Created " & PDFfile, vbInformation
           
        Else
       
            MsgBox "Partial subfolder name '" & .ActiveSheet.Range("H10").Value & "' not found in root folder " & .ActiveSheet.Range("A52").Value, vbExclamation
           
        End If
       
    End With
   
End Sub


'Breadth-first folder traverse looking for partial subfolder name starting at specified folder

Private Function Find_Subfolder(folderPath As String, findPartialSubfolderName As String) As String

    Static FSO As FileSystemObject
    Dim FSfolder As folder, FSsubfolder As folder
   
    If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
   
    Set FSfolder = FSO.GetFolder(folderPath)
    
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If InStr(1, FSsubfolder.Path, findPartialSubfolderName, vbTextCompare) Then
            Find_Subfolder = FSsubfolder.Path & "\"
            Exit For
        End If
    Next
   
    If Find_Subfolder = "" Then
        For Each FSsubfolder In FSfolder.subfolders
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, findPartialSubfolderName)
            If Find_Subfolder <> "" Then
                Exit For
            End If
        Next
    End If
   
End Function
Click to expand...
Hey John,

So... when I try to run this sub, it returns this error. Any ideas?

1633007889855.png
 
Upvote 0
thedoccontroller said:
@John_w , I've tried all I know to make this run, but nothing seems to be working(as far as location for the sub and running it without the button). I'm sure I'm missing something simple, but it's just not showing itself.
Click to expand...
@John_w
Okay... Figured it out. I had never checked off the "Microsoft Scripting Runtime" in Tools\References. After initiating that, there was a little delay the first time the code ran, but ba da bing! You nailed it. I changed the "naming" dialogue to fit the title I wanted and we are good to go.

If I wanted to alter this to save the file to the same location as an xls, would that be possible?
 
Upvote 0
thedoccontroller said:
Okay... Figured it out. I had never checked off the "Microsoft Scripting Runtime" in Tools\References. After initiating that, there was a little delay the first time the code ran, but ba da bing! You nailed it. I changed the "naming" dialogue to fit the title I wanted and we are good to go.
Click to expand...
Sorry about the compile error. The code is meant to use late binding of "Microsoft Scripting Runtime", but I left in the early binding data type declaration Static FSO As FileSystemObject. To use late binding without needing the reference simply change the data type declaration to Static FSO As Object
thedoccontroller said:
If I wanted to alter this to save the file to the same location as an xls, would that be possible?
Click to expand...

Which xls? Do you mean in the same folder as the macro workbook itself? If so, replace:
VBA Code: 
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
with:
VBA Code: 
        saveInFolder = ThisWorkbook.Path & "\"
 
Upvote 0
John_w said:
Sorry about the compile error. The code is meant to use late binding of "Microsoft Scripting Runtime", but I left in the early binding data type declaration Static FSO As FileSystemObject. To use late binding without needing the reference simply change the data type declaration to Static FSO As Object


Which xls? Do you mean in the same folder as the macro workbook itself? If so, replace:
VBA Code: 
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
with:
VBA Code: 
        saveInFolder = ThisWorkbook.Path & "\"
Click to expand...
Wanting the option to save this as an xlsm in the same location as the pdf. They will need to have the pdf in one scenario or the copy of the xlms in another. Does that make sense?
 
Upvote 0
John_w said:
Sorry about the compile error. The code is meant to use late binding of "Microsoft Scripting Runtime", but I left in the early binding data type declaration Static FSO As FileSystemObject. To use late binding without needing the reference simply change the data type declaration to Static FSO As Object


Which xls? Do you mean in the same folder as the macro workbook itself? If so, replace:
VBA Code: 
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
with:
VBA Code: 
        saveInFolder = ThisWorkbook.Path & "\"
Click to expand...
Well... I tried. I went thru and changed all the references to xlms, and it seemed to work(long working pause like before), but then it crashed with a "doesen't support this object" DB.

Here's what I did:

VBA Code: 
Public Sub Save_Sheets_As_XLMS()

    Dim saveInFolder As String
    Dim PDFfile As String
    Dim currentSheet As Worksheet
    Dim i As Long
    Dim replaceSelected As Boolean
    
    With ActiveWorkbook
    
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
    
        If saveInFolder <> "" Then
        
            XLfile = saveInFolder & "PE Insp.xlms"
    
            Set currentSheet = .ActiveSheet
            replaceSelected = True
            For i = .ActiveSheet.Index + 1 To .Sheets.Count
                .Sheets(i).Select replaceSelected
                replaceSelected = False
            Next
            
            .ActiveSheet.ExportAsxlExcel4MacroSheet Type:=xlTypexlms, Filename:=XLfile, _
                Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            currentSheet.Select True
            
            MsgBox "Created " & PDFfile, vbInformation
            
        Else
        
            MsgBox "Partial subfolder name '" & .ActiveSheet.Range("H10").Value & "' not found in root folder " & .ActiveSheet.Range("A52").Value, vbExclamation
            
        End If
        
    End With
    
End Sub


'Breadth-first folder traverse looking for partial subfolder name starting at specified folder

Private Function Find_Subfolder(folderPath As String, findPartialSubfolderName As String) As String

    Static fso As Object
    Dim FSfolder As folder, FSsubfolder As folder
    
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
    
    Set FSfolder = fso.GetFolder(folderPath)
     
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If InStr(1, FSsubfolder.Path, findPartialSubfolderName, vbTextCompare) Then
            Find_Subfolder = FSsubfolder.Path & "\"
            Exit For
        End If
    Next
    
    If Find_Subfolder = "" Then
        For Each FSsubfolder In FSfolder.subfolders
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, findPartialSubfolderName)
            If Find_Subfolder <> "" Then
                Exit For
            End If
        Next
    End If
    
End Function
 
Upvote 0
thedoccontroller said:
Well... I tried. I went thru and changed all the references to xlms, and it seemed to work(long working pause like before), but then it crashed with a "doesen't support this object" DB.

Here's what I did:

VBA Code: 
Public Sub Save_Sheets_As_XLMS()

    Dim saveInFolder As String
    Dim PDFfile As String
    Dim currentSheet As Worksheet
    Dim i As Long
    Dim replaceSelected As Boolean
   
    With ActiveWorkbook
   
        saveInFolder = Find_Subfolder(.ActiveSheet.Range("A52").Value, .ActiveSheet.Range("H10").Value)
   
        If saveInFolder <> "" Then
       
            XLfile = saveInFolder & "PE Insp.xlms"
   
            Set currentSheet = .ActiveSheet
            replaceSelected = True
            For i = .ActiveSheet.Index + 1 To .Sheets.Count
                .Sheets(i).Select replaceSelected
                replaceSelected = False
            Next
           
            .ActiveSheet.ExportAsxlExcel4MacroSheet Type:=xlTypexlms, Filename:=XLfile, _
                Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            currentSheet.Select True
           
            MsgBox "Created " & PDFfile, vbInformation
           
        Else
       
            MsgBox "Partial subfolder name '" & .ActiveSheet.Range("H10").Value & "' not found in root folder " & .ActiveSheet.Range("A52").Value, vbExclamation
           
        End If
       
    End With
   
End Sub


'Breadth-first folder traverse looking for partial subfolder name starting at specified folder

Private Function Find_Subfolder(folderPath As String, findPartialSubfolderName As String) As String

    Static fso As Object
    Dim FSfolder As folder, FSsubfolder As folder
   
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
   
    Set FSfolder = fso.GetFolder(folderPath)
    
    Find_Subfolder = ""
    For Each FSsubfolder In FSfolder.subfolders
        If InStr(1, FSsubfolder.Path, findPartialSubfolderName, vbTextCompare) Then
            Find_Subfolder = FSsubfolder.Path & "\"
            Exit For
        End If
    Next
   
    If Find_Subfolder = "" Then
        For Each FSsubfolder In FSfolder.subfolders
            Find_Subfolder = Find_Subfolder(FSsubfolder.Path, findPartialSubfolderName)
            If Find_Subfolder <> "" Then
                Exit For
            End If
        Next
    End If
   
End Function
Click to expand...
@John_w,
Sometimes I'm dumb... xlsm might help....and it does not... here's the error:
1633029215165.png
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Include Path's with more than 260 characters
Replies
4
Views
598
Bosquedeguate
Bosquedeguate
M
  • Question
Excel VBA Save PDF within workbook folder and send as email attachment
Replies
1
Views
276
rpaulson
rpaulson
B
  • Solved
VBA macro to copy files from one folder (and all it's subfolders, and their subfolders, and their subfolders with an exception....) to another folder?
Replies
4
Views
727
Bering
B
JoshLyman
  • Solved
Save specific sheet as PDF
2
Replies
11
Views
2K
tahmed5835
T
I
  • Question
Saving as pdf file from another sheet
Replies
1
Views
444
ipbr21054
I

Forum statistics

Threads
1,215,453
Messages
6,124,930
Members
449,195
Latest member
Stevenciu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top