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

[Donbozone]

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

 

[maabadi]

Test This:

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]

Sorry Try this:

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]

Test This:
Option Explicit

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]

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]

Then Change

Filename:=FolderName & "\" & .Range("C14").Value

to

Filename:=FolderName & "\" & .Range("E" & i).Value

 

[Donbozone]

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]

Sorry My Fault:

Filename:=FolderName & "\" & Worksheets("Sheet2").Range("E" & i).Value

 

[Donbozone]

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]

I Don't think it is Possible, Maybe another one Knows.