VBA code - print to pdf and auto save pdf file (File Name To Equal Cell Value)

Donbozone

New Member
Joined
Mar 28, 2020
Messages
37
Office Version
  1. 365
Platform
  1. Windows
Hello to everyone.

I would appreciate if someone can help.

Here is what I have and what I need:

  • I have a source sheet "zaposleni" (it is in Serbian, don't pay attention) and a template sheet called "potvrda PPP-PO"
  • I have a simple VBA code which takes one information from table source and copy it in my template sheet (based on that information other cells in my template are auto-filled with formulas) and after that it starts printing one by one:
Here it is:​
Sub PrintAll()​
Dim i As Long, LastRow As Long​
LastRow = Worksheets("zaposleni").Range("B1000").End(xlUp).Row​
With Worksheets("potvrda PPP-PO")​
For i = 2 To LastRow​
.Range("C14").Value = Worksheets("zaposleni").Range("B" & i).Value​
.Range("Print_Me").PrintOut​
Next i​
If .FilterMode Then .ShowAllData​
End With​
End Sub​

  • This is ok if I want to save one by one manually or merge all in one pdf file, but what I need is the option of auto saving of each file as per specified name.
  • As the path to the folder is required it would be also nice to add browser window (to avoid fixing the path in the code) so I could chose the folder in which my pdf files will be stored.
  • I would add file names in my source table, sheet "zaposleni" in first empty column which is column "E"

This is how the code supposed to work:

  • Start code
  • Browser window opens and ask me where I want to save my pdf files
  • I'm choosing existing or creating a new folder
  • code takes first value from source table (zaposleni B2) and paste in my template sheet
  • code prints template to pdf and takes the name from the same row in source table (my table has headers, so it would be E2) and saves the pdf file under that name
  • operation repeats with row 3 and so on to the last non-empty row in column B of my source table

Hope I was clear and hope it is feasible :)

Thanks
 

Some videos you may like

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Test This:
VBA Code:
Sub PrintAll ()

Dim i As Long, LastRow As Long
LastRow = Worksheets("zaposleni").Cells(Rows.Count, 2).End(xlUp).Row
On Error GoTo err
    Dim fileExplorer As FileDialog
    Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)

    'To allow or disable to multi select
    fileExplorer.AllowMultiSelect = False

    With fileExplorer
        If .Show = -1 Then 'Any folder is selected
            [folderPath] = .SelectedItems.Item(1)
        Else ' else dialog is cancelled
            MsgBox "You have cancelled the dialogue"
            [folderPath] = "" ' when cancelled set blank as file path.
        End If
    End With
err:
    Exit Sub
 
    With Worksheets("potvrda PPP-PO")
For i = 2 To LastRow
.Range("C14").Value = Worksheets("zaposleni").Range("B" & i).Value
.Range("Print_Me").ExportAsFixedFormat Type:=xlTypePDF, Filename:=.Range("C14").Value, _
    Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next i
If .FilterMode Then .ShowAllData

End With

End Sub
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Sorry Try this:
VBA Code:
Option Explicit

Sub UniqueListTransposed()
 
 Dim i As Long, LastRow As Long, FolderPath As String
 Dim fldr As FileDialog, sItem As String, FolderName As String
 LastRow = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row

    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    FolderName = sItem
    Set fldr = Nothing
    

    ' If the user didn't select anything, you can't save, so tell them so:
    If FolderName = "" Then
        MsgBox "No folder was selected. Program will terminate."
        Exit Sub
    End If

    ' Create a path by combining the file and folder names:
    'File_Name = FolderName & "\" & File_Name & ".xlsm"

    
    With Worksheets("Sheet1")
For i = 2 To LastRow
.Range("C14").Value = Worksheets("Sheet2").Range("B" & i).Value
.Range("A1:E20").ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderName & "\" & .Range("C14").Value, _
    Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next i
If .FilterMode Then .ShowAllData

End With

End Sub
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Test This:
Option Explicit

VBA Code:
Sub ImportFiles()
Dim wbOpen As Workbook, wbNew As Workbook, fName As String, strPath As String
Dim FolderPath As String, fldr As FileDialog, sItem As String, FolderName As String
Dim FileName As String, Sheet As Worksheet
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
   
Set wbNew = Workbooks.Add
'wbNew.SaveAs FileName:="C:\Users\swaroopa.bp\Desktop\C\Consolidation", FileFormat:=xlWorkbookNormal
FileName = Dir(FolderPath & "*.xls*")
MsgBox ("Do you Want to Extract Files?")
'Comment out the 3 lines below to debug
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
ActiveSheet.Name = ActiveSheet.Range("F6")
'wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
Next Sheet
Workbooks(FileName).Close
FileName = Dir()
Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
MsgBox ("Files Extracted Succussfully")
fName = Dir(FolderPath & "*.*")
Do While fName <> ""
If fName <> "Master1.xls" And fName <> "Master2.xls" Then 'or .txt or .csv or whatever
Kill FolderPath & fName
End If
fName = Dir
Loop
End Sub
 

Donbozone

New Member
Joined
Mar 28, 2020
Messages
37
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi. Thank you for your help.

The second one does the job. The only problem is the file name which is equal to the value from column B of my source sheet (the value that code copy and paste to the template) and it supposed to be equal to the value of column E of my source table.

I guess that this part of code is problematic:

With Worksheets("Sheet1")
For i = 2 To LastRow
.Range("C14").Value = Worksheets("Sheet2").Range("B" & i).Value
.Range("A1:E20").ExportAsFixedFormat Type:=xlTypePDF, Filename:=FolderName & "\" & .Range("C14").Value, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False

It probably refers to take name from C14 of my template sheet?


Thanks
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Then Change
VBA Code:
Filename:=FolderName & "\" & .Range("C14").Value
to
VBA Code:
Filename:=FolderName & "\" & .Range("E" & i).Value
 

Donbozone

New Member
Joined
Mar 28, 2020
Messages
37
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Just a question, does: ("E" & i)[/B].Value

refers to the same sheet as: ("C14")[/B].Value?

I need ("E" & i) from source sheet which is template sheet.


Thanks
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Sorry My Fault:
VBA Code:
Filename:=FolderName & "\" & Worksheets("Sheet2").Range("E" & i).Value
 

Donbozone

New Member
Joined
Mar 28, 2020
Messages
37
Office Version
  1. 365
Platform
  1. Windows
Yes, this is it.

I forgot one more thing.

Would it be possible to add a password protection to each pdf file?

I would probably add passwords to my next empty column of source list, which would be column "F"
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
1,615
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I Don't think it is Possible, Maybe another one Knows.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,405
Messages
5,624,574
Members
416,036
Latest member
eloisa manzanarez

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
Top