Excel templates to PDF

Le 13/09/2016 à 17:56

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 but I would like to amend two things ! (questions are right below the code)

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 ?

Voilà, Many thanks in advance!

Le 13/09/2016 à 18:54

Hello,

If you want an English-speaking forum, you can go possibly on mrexcel.com

(if it's more easy for you )

P.

Le 14/09/2016 à 13:26

Hello,

Désolé je n'ai pas fait attention en postant.

Je parle francais il n'y a pas de soucis je vais reposter en francais :

coolworld a écrit :

Bonjour,

J'ai trouvé en cherchant sur le web une macro VBA qui me permet de transférer automatiquement les données remplies dans un spreadsheet ("Main") vers un autre (Template) et qui génère automatiquement un nouveau workbook pour chaque ligne remplie dans le premier spreadsheet.

Tout fonctionne mais j'aurais deux questions (en bas du code)

Voici le 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

2 Questions

1) Comment supprimer la possibilité de générer les workbooks dans le même workbook ?

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

2) Est-il possible à la place de générer des workbooks excel de générer des fichiers PDF ? Cela implique-t-il une lourde modification du code ?

Voilà, merci d'avance

Le 14/09/2016 à 14:22

Bonjour,

A tester car sans fichier joint...

Cdlt.

'Option Explicit

Sub FillOutTemplate()
Dim LastRw As Long, Rw As Long, Cnt As Long
Dim dSht As Worksheet, tSht As Worksheet
Dim MakeBooks As Boolean, SavePath As String

    response = MsgBox("Are you sure you want to save ?", vbYesNo)

    If response = vbNo Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If

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

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Set dSht = Sheets("Main")
    Set tSht = Sheets("Template")

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

    LastRw = dSht.Range("A" & Rows.Count).End(xlUp).Row
    tSht.Copy After:=Worksheets(Worksheets.Count)
    For Rw = 4 To LastRw
        With ActiveSheet
            .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

            .ExportAsFixedFormat Type:=xlTypePDF, _
                                 Filename:=SavePath & .Range("E2").Value & ".pdf", _
                                 quality:=xlQualityMinimum, _
                                 IncludeDocProperties:=True, _
                                 IgnorePrintAreas:=True, _
                                 OpenAfterPublish:=False
        End With
        Cnt = Cnt + 1
    Next Rw

    ActiveSheet.Delete
    dSht.Activate

    MsgBox "PDF files created: " & Format(Cnt, "00")

    Application.DisplayAlerts = True

End Sub
Le 14/09/2016 à 15:07

Waw, c'est super tout fonctionne !

Merci Jean-Eric et Patrick!

Je n'hésiterai pas à revenir sur le forum :p

Rechercher des sujets similaires à "templates pdf"