Excel templates to PDF

[coolworld]

Hello,

I am delighted to use the forum for the first time.

I encounter an issue with my excel vba function.
Not being a coder, I went online looking for some vba code that would allow me to "print" a template version ("Template" spreadsheet) of the rows info filled on a first sheet ("Main" spreadsheet).

So I found something. that works.

Here is the code :

Sub FillOutTemplate()

response = MsgBox("Are you sure you want to save ?", vbYesNo)
 
If response = vbNo Then
    MsgBox ("Operation cancelled.")
    Exit Sub
End If

rspn = InputBox("Please enter password")
If rspn <> "secret" Then
    MsgBox "Operation cancelled."
    Exit Sub
End If

Dim LastRw As Long, Rw As Long, Cnt As Long
Dim dSht As Worksheet, tSht As Worksheet
Dim MakeBooks As Boolean, SavePath As String

Application.ScreenUpdating = False  'speed up macro execution
Application.DisplayAlerts = False   'no alerts, default answers used

Set dSht = Sheets("Main")           'sheet with data on it starting in row4
Set tSht = Sheets("Template")       'sheet to copy and fill out

'Option to create separate workbooks
    MakeBooks = MsgBox("Create separate workbooks?" & vbLf & vbLf & _
        "YES = template will be copied to separate workbooks." & vbLf & _
        "NO = template will be copied to sheets within this same workbook", _
            vbYesNo + vbQuestion) = vbYes

If MakeBooks Then   'select a folder for the new workbooks
    MsgBox "Please select a destination to save the Personal Information Templates"
    Do
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count > 0 Then    'a folder was chosen
                SavePath = .SelectedItems(1) & "\"
                Exit Do
            Else                                'a folder was not chosen
                If MsgBox("Do you wish to abort?", _
                    vbYesNo + vbQuestion) = vbYes Then Exit Sub
            End If
        End With
    Loop
End If

'Determine last row of data then loop through the rows one at a time
    LastRw = dSht.Range("A" & Rows.Count).End(xlUp).Row
    
    For Rw = 4 To LastRw
        tSht.Copy After:=Worksheets(Worksheets.Count)   'copy the template
        With ActiveSheet                                'fill out the form
            'edit these rows to fill out your form, add more as needed
            .Name = dSht.Range("F" & Rw)
            .Range("E1").Value = dSht.Range("A" & Rw).Value
            .Range("B2").Value = dSht.Range("F" & Rw).Value
            .Range("C2").Value = dSht.Range("G" & Rw).Value
            .Range("E2").Value = dSht.Range("E" & Rw).Value
            
            .Range("D4").Value = dSht.Range("F" & Rw).Value
            .Range("D6").Value = dSht.Range("G" & Rw).Value
            .Range("D8").Value = dSht.Range("H" & Rw).Value
            .Range("D9").Value = dSht.Range("I" & Rw).Value
            
            .Range("D11").Value = dSht.Range("J" & Rw).Value
            .Range("D12").Value = dSht.Range("K" & Rw).Value
            .Range("D13").Value = dSht.Range("L" & Rw).Value
            
            .Range("D15").Value = dSht.Range("M" & Rw).Value
            .Range("D16").Value = dSht.Range("N" & Rw).Value
            .Range("D17").Value = dSht.Range("O" & Rw).Value
            
            .Range("D19").Value = dSht.Range("P" & Rw).Value
            .Range("D20").Value = dSht.Range("Q" & Rw).Value
            .Range("D21").Value = dSht.Range("R" & Rw).Value
            
            .Range("D23").Value = dSht.Range("S" & Rw).Value
            .Range("D24").Value = dSht.Range("T" & Rw).Value
            .Range("D25").Value = dSht.Range("U" & Rw).Value
            .Range("D26").Value = dSht.Range("V" & Rw).Value
            .Range("D27").Value = dSht.Range("W" & Rw).Value
            .Range("D28").Value = dSht.Range("X" & Rw).Value
            .Range("D29").Value = dSht.Range("Y" & Rw).Value
        
            .Range("D31").Value = dSht.Range("Z" & Rw).Value
            .Range("D32").Value = dSht.Range("AA" & Rw).Value
            
            .Range("D34").Value = dSht.Range("AB" & Rw).Value
            
            .Range("D36").Value = dSht.Range("AC" & Rw).Value
            
            
        End With
        
        If MakeBooks Then       'if making separate workbooks from filled out form
            ActiveSheet.Move
            ActiveWorkbook.SaveAs SavePath & Range("E2").Value, xlNormal
            ActiveWorkbook.Close False
        End If
        Cnt = Cnt + 1
    Next Rw

    dSht.Activate
    If MakeBooks Then
        MsgBox "Workbooks created: " & Cnt
    Else
        MsgBox "Worksheets created: " & Cnt
    End If
    
Application.ScreenUpdating = True
End Sub

There are two things I would like to fix,
1) How to delete the option of choosing between saving all the templates in the same workbook ?? I would like that the only option is to save the templates in separate workbooks.

("YES = template will be copied to separate workbooks." & vbLf & _
 "NO = template will be copied to sheets within this same workbook", _)

2) How to instead of generating multiple workbooks, it would generate multiple PDF ? Is there a lot to do to adapt the code ?

Many thanks in advance!

[coolworld]

Anyone ?

[Kenneth Hobs]

IT is easy enough to do the first.

The second is not that involved either. One can create a scratch workbook or just add and delete a sheet to the existing file. I think that the former is safer.

Rather than the SaveAs, you would just make a call to this sort of routine or use parts directly.

Function PublishToPDF(fName As String, o As Object, _  
  Optional tfGetFilename As Boolean = False) As String
  Dim rc As Variant
  rc = fName
  If tfGetFilename Then
    rc = Application.GetSaveAsFilename(fName, "PDF (*.pdf), *.pdf", 1, "Publish to PDF")
    If rc = "" Then Exit Function
  End If
  
  o.ExportAsFixedFormat Type:=xlTypePDF, fileName:=rc _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
  :=False, OpenAfterPublish:=False
  
  PublishToPDF = rc
End Function

[coolworld]

Hi Kenneth,

Thanks for your reply.

Sorry in advance for the "basic" questions --> Could you provide me more details about :
1) How to remove the possibility to save the templates as multiple sheets within the same workbook ?

("YES = template will be copied to separate workbooks." & vbLf & _ 
"NO = template will be copied to sheets within this same workbook", _) 

2) The code you sent me. I understand it is related to creation of PDF (instead of xls) files. Where should I enter it ? In the code I sent you ? In a separate module ?

Many thanks in advance for your help.

IT is easy enough to do the first.

The second is not that involved either. One can create a scratch workbook or just add and delete a sheet to the existing file. I think that the former is safer.

Rather than the SaveAs, you would just make a call to this sort of routine or use parts directly.

Function PublishToPDF(fName As String, o As Object, _  
  Optional tfGetFilename As Boolean = False) As String
  Dim rc As Variant
  rc = fName
  If tfGetFilename Then
    rc = Application.GetSaveAsFilename(fName, "PDF (*.pdf), *.pdf", 1, "Publish to PDF")
    If rc = "" Then Exit Function
  End If
  
  o.ExportAsFixedFormat Type:=xlTypePDF, fileName:=rc _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
  :=False, OpenAfterPublish:=False
  
  PublishToPDF = rc
End Function

[Kenneth Hobs]

As I said, (1) is easy enough. I'll show you in another reply.

What you might prefer is to approach this in another way. Just make a sheet as the template which I think you have. Then fill it out with data, say by row from another sheet, then create the pdf. That is what this file does.

As for (2), if that is still needed, as I said replace your SaveAs line of code with a call. e.g.

PublishToPDF SavePath & Range("E2").Value & ".pdf", ActiveSheet

[Kenneth Hobs]

I don't have you file to test. Be sure to make a backup copy when testing code.

It might go something like:

Option Explicit

 
Sub FillOutTemplate()
  Dim LastRw As Long, Rw As Long
  Dim dSht As Worksheet, tSht As Worksheet
  Dim SavePath As String
   
   
  On Error GoTo EndNow
  Application.ScreenUpdating = False 'speed up macro execution
  Application.DisplayAlerts = False 'no alerts, default answers used
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
   
  Set dSht = Sheets("Main") 'sheet with data on it starting in row4
  Set tSht = Sheets("Template") 'sheet to copy and fill out
   
  MsgBox "Please select a destination to save the Personal Information Templates"
  Do
    With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .Show
        If .SelectedItems.Count > 0 Then 'a folder was chosen
          SavePath = .SelectedItems(1) & "\"
          Exit Do
          Else 'a folder was not chosen
            If MsgBox("Do you wish to abort?", _
              vbYesNo + vbQuestion) = vbYes Then GoTo EndNow
        End If
      End With
  Loop
   
   'Determine last row of data then loop through the rows one at a time
  LastRw = dSht.Range("A" & Rows.Count).End(xlUp).Row
   
  For Rw = 4 To LastRw
      With tSht 'fill out the form
         'edit these rows to fill out your form, add more as needed
        .Range("E1").Value = dSht.Range("A" & Rw).Value
        .Range("B2").Value = dSht.Range("F" & Rw).Value
        .Range("C2").Value = dSht.Range("G" & Rw).Value
        .Range("E2").Value = dSht.Range("E" & Rw).Value
         
        .Range("D4").Value = dSht.Range("F" & Rw).Value
        .Range("D6").Value = dSht.Range("G" & Rw).Value
        .Range("D8").Value = dSht.Range("H" & Rw).Value
        .Range("D9").Value = dSht.Range("I" & Rw).Value
         
        .Range("D11").Value = dSht.Range("J" & Rw).Value
        .Range("D12").Value = dSht.Range("K" & Rw).Value
        .Range("D13").Value = dSht.Range("L" & Rw).Value
         
        .Range("D15").Value = dSht.Range("M" & Rw).Value
        .Range("D16").Value = dSht.Range("N" & Rw).Value
        .Range("D17").Value = dSht.Range("O" & Rw).Value
         
        .Range("D19").Value = dSht.Range("P" & Rw).Value
        .Range("D20").Value = dSht.Range("Q" & Rw).Value
        .Range("D21").Value = dSht.Range("R" & Rw).Value
         
        .Range("D23").Value = dSht.Range("S" & Rw).Value
        .Range("D24").Value = dSht.Range("T" & Rw).Value
        .Range("D25").Value = dSht.Range("U" & Rw).Value
        .Range("D26").Value = dSht.Range("V" & Rw).Value
        .Range("D27").Value = dSht.Range("W" & Rw).Value
        .Range("D28").Value = dSht.Range("X" & Rw).Value
        .Range("D29").Value = dSht.Range("Y" & Rw).Value
         
        .Range("D31").Value = dSht.Range("Z" & Rw).Value
        .Range("D32").Value = dSht.Range("AA" & Rw).Value
         
        .Range("D34").Value = dSht.Range("AB" & Rw).Value
         
        .Range("D36").Value = dSht.Range("AC" & Rw).Value
        
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=SavePath _
          & Range("E2").Value & ".pdf", Quality:=xlQualityStandard, _
          IncludeDocProperties:=True, IgnorePrintAreas:=False, _
          OpenAfterPublish:=False
      End With
  Next Rw
   
   
EndNow:
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

[coolworld]

many thanks guys ! it works superb