VBA Print selected sheets individually as PDF with set up name and date

[Morty]

Hello all . I have workbook with 11 sheets, first one is "Summary" and the rest 10 are all identical and are used as template ready to fill and printout. I would like to print as PDF only selected active sheets individualy to seted up folder. I have found amazing macro, but my capabilities to adjust it to my needs are limited :D. The date format added to file name is desired, but I would need to change the core name accordingly to values in merged cell E15 & E13, see below. Momentaly the code prints only 1 selected sheet.

CODE SAMPLE

Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

MY SHEET SAMPLE

Test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1
2
3
4
5
6
7
8
9
10			Building:
11
12
13			Object number:
14
15			SO name:
16
17
18
19
20
21
List 11

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C19:J30	Cell	does not contain a blank value	text	NO

Thank you all for your replies and I wish you nice rest of the day .

Sincerely,
Morty

 

[EFANYoutube]

I think the below should do what you want, you would run "DoEachOne"
It does every sheet but you could put in a condition to stop it doing ones you don't want

Dim SameDIR As Boolean
Dim DIR_ToSave As String

Function PDF_WorkSheet(wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Range("E15") & "_" & wsA.Range("E13"), " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
If SameDIR = True Then
    myFile = DIR_ToSave
Else
    myFile = Application.GetSaveAsFilename _
        (InitialFileName:=strPathFile, _
            FileFilter:="PDF Files (*.pdf), *.pdf", _
            Title:="Select Folder and FileName to save")
End If
'Ask if want same Directory for all sheets
If MsgBox("Do you want to use the same directory for all the sheets?", vbYesNo, "Use for all?") = vbYes Then
    SameDIR = True
    DIR_ToSave = myFile
End If

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Function
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Function

Sub DoEachOne()
    
    For Each Sheet In ThisWorkbook.Sheets
        PDF_WorkSheet Sheet
    Next Sheet
    SameDIR = False
End Sub

 

[Morty]

I think the below should do what you want, you would run "DoEachOne"
It does every sheet but you could put in a condition to stop it doing ones you don't want

Dim SameDIR As Boolean
Dim DIR_ToSave As String

Function PDF_WorkSheet(wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Range("E15") & "_" & wsA.Range("E13"), " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
If SameDIR = True Then
    myFile = DIR_ToSave
Else
    myFile = Application.GetSaveAsFilename _
        (InitialFileName:=strPathFile, _
            FileFilter:="PDF Files (*.pdf), *.pdf", _
            Title:="Select Folder and FileName to save")
End If
'Ask if want same Directory for all sheets
If MsgBox("Do you want to use the same directory for all the sheets?", vbYesNo, "Use for all?") = vbYes Then
    SameDIR = True
    DIR_ToSave = myFile
End If

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Function
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Function

Sub DoEachOne()
  
    For Each Sheet In ThisWorkbook.Sheets
        PDF_WorkSheet Sheet
    Next Sheet
    SameDIR = False
End Sub

Hi and thank you . I have tried your upgrade, but unfortunately it reports error due to part PDF_WorkSheet "Sheet". The error message is: "ByRef argument type mismatch"

Sub DoEachOne()
  
    For Each Sheet In ThisWorkbook.Sheets
        PDF_WorkSheet Sheet
    Next Sheet
    SameDIR = False
End Sub

 

[EFANYoutube]

Sorry about that

See an update below

Dim SameDIR As Boolean
Dim DIR_ToSave As String

Function PDF_WorkSheet(byVal wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String

 

[Morty]

Sorry about that

See an update below

Dim SameDIR As Boolean
Dim DIR_ToSave As String

Function PDF_WorkSheet(byVal wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String

Now the error changed to Compile error: Duplicate declaration in current scope highlighting starting part of the macro : Function PDF_WorkSheet(ByVal wsA As Worksheet) and Dim wsA As Worksheet :D.

 

[EFANYoutube]

Sorry I forgot to take this out. You don't need the Dim wsA in the code because the function already creates it

Function PDF_WorkSheet(byVal wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet '     <----Remove this line
Dim wbA As Workbook

 

[Morty]

Sorry I forgot to take this out. You don't need the Dim wsA in the code because the function already creates it

Function PDF_WorkSheet(byVal wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet '     <----Remove this line
Dim wbA As Workbook

No need for apologies :D. Now it is working, but the values from E13 and E15 are not implemented so file´s name is for example _20210622_0824 and it is still doing for all sheets and due to the same name its overwriting itself again and again :D. Looks like its not that easy as i thought :D.

 

[Morty]

Ad #7 I have tried it with just 2 sample sheets and it worked, maybe there is problem with first sheet which is used as Summary. So if it prints only selected sheets it could work properly. And just 1 more thing. Its asking after every sheet if i want to save it to same dictionary regardless if i choose yes or no :D. Its little bit strange and annoying :D

 

[EFANYoutube]

For the summary sheet issue try to ignore it like this and I have removed the question so you will just need to tell it where each time.
If you want it to ask I can fix the code to do the right thing

Function PDF_WorkSheet(ByRef wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later

Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Range("E15") & "_" & wsA.Range("E13"), " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"


strPathFile = strPath & strFile

'use can enter name and
' select folder for file

myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")


'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Function
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Function

Sub DoEachOne()

    
    Dim sheet As Worksheet
    For Each sheet In ThisWorkbook.Sheets

        If sheet.Name <> "Summary" Then

            PDF_WorkSheet sheet
        
        End If

    Next sheet

    SameDIR = False

End Sub

 

[Morty]

For the summary sheet issue try to ignore it like this and I have removed the question so you will just need to tell it where each time.
If you want it to ask I can fix the code to do the right thing

Function PDF_WorkSheet(ByRef wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later

Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Range("E15") & "_" & wsA.Range("E13"), " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"


strPathFile = strPath & strFile

'use can enter name and
' select folder for file

myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")


'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Function
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Function

Sub DoEachOne()

   
    Dim sheet As Worksheet
    For Each sheet In ThisWorkbook.Sheets

        If sheet.Name <> "Summary" Then

            PDF_WorkSheet sheet
       
        End If

    Next sheet

    SameDIR = False

End Sub

Hoooray now its working properly in the matter of filenames . Last 2 things. Is it posible to save only selected sheets, or pop up messagebar to ask range of which only to extract? That was the main problem whole time :D. I guess the option with selecting by mouse will be easier :D. Like if is possible that coworkers fill only first 3 templates sheets, select them, pop up this macro and it would just ask once where to save extracted pdfs and extract only these for example first 3 sheets. To avoid saving all sheets everytime . Once again thank you so much man :D.