Looping through an Excel Sheet copying and pasting different values and save all resulted copies to the same pdf file

Question

When this button is clicked it will

copy values from specific Cells in a table inside CustomersSupport Sheet and,
paste it to specific Cells in the StandardMDForm Sheet then,
print out the StandardMDForm Sheet

Here is My Code:

Private Sub printMDs_Click()

Dim i As Long
Dim FolderPath As String

'Destination Directory to Save the PDF Files
FolderPath = GetDesktop() & "\MDs"

MkDir (FolderPath)

    'Loop through Rows from 5 to 84
    For i = 5 To 84

        'Check if Doctor Name is Available
        If Not IsEmpty(Worksheets("CustomersSupport").Cells(i, "I")) Then

        'Doctor Details
        Worksheets("StandardMDForm").Range("B4").Value = Worksheets("CustomersSupport").Cells(i, "I").Value
        Worksheets("StandardMDForm").Range("B5").Value = Worksheets("CustomersSupport").Cells(i, "G").Value
        Worksheets("StandardMDForm").Range("B6").Value = Worksheets("CustomersSupport").Cells(i, "H").Value
        Worksheets("StandardMDForm").Range("B7").Value = Worksheets("CustomersSupport").Cells(i, "E").Value
        Worksheets("StandardMDForm").Range("B9").Value = Worksheets("CustomersSupport").Cells(i, "J").Value
        Worksheets("StandardMDForm").Range("E5").Value = Worksheets("CustomersSupport").Cells(i, "C").Value
        Worksheets("StandardMDForm").Range("E6").Value = Worksheets("CustomersSupport").Cells(i, "F").Value
        Worksheets("StandardMDForm").Range("E7").Value = Worksheets("CustomersSupport").Cells(i, "D").Value
        Worksheets("StandardMDForm").Range("B10").Value = Worksheets("CustomersSupport").Cells(i, "K").Value

        'Brand 1
        Worksheets("StandardMDForm").Range("B14").Value = Worksheets("CustomersSupport").Cells(i, "L").Value
        Worksheets("StandardMDForm").Range("B15").Value = Worksheets("CustomersSupport").Cells(i, "M").Value
        Worksheets("StandardMDForm").Range("B18").Value = Worksheets("CustomersSupport").Cells(i, "N").Value

        'Brand 2
        Worksheets("StandardMDForm").Range("C14").Value = Worksheets("CustomersSupport").Cells(i, "O").Value
        Worksheets("StandardMDForm").Range("C15").Value = Worksheets("CustomersSupport").Cells(i, "P").Value
        Worksheets("StandardMDForm").Range("C18").Value = Worksheets("CustomersSupport").Cells(i, "Q").Value

        'Brand 3
        Worksheets("StandardMDForm").Range("D14").Value = Worksheets("CustomersSupport").Cells(i, "R").Value
        Worksheets("StandardMDForm").Range("D15").Value = Worksheets("CustomersSupport").Cells(i, "S").Value
        Worksheets("StandardMDForm").Range("D18").Value = Worksheets("CustomersSupport").Cells(i, "T").Value

        'Brand 4
        Worksheets("StandardMDForm").Range("E14").Value = Worksheets("CustomersSupport").Cells(i, "U").Value
        Worksheets("StandardMDForm").Range("E15").Value = Worksheets("CustomersSupport").Cells(i, "V").Value
        Worksheets("StandardMDForm").Range("E18").Value = Worksheets("CustomersSupport").Cells(i, "W").Value

        'Brand 5
        Worksheets("StandardMDForm").Range("F14").Value = Worksheets("CustomersSupport").Cells(i, "X").Value
        Worksheets("StandardMDForm").Range("F15").Value = Worksheets("CustomersSupport").Cells(i, "Y").Value
        Worksheets("StandardMDForm").Range("F18").Value = Worksheets("CustomersSupport").Cells(i, "Z").Value

        'Print MD Sheet
        Sheets("StandardMDForm").PrintOut

        End If

    Next

    'Focus back to the "CustomersSupport" Sheet
    Sheets("CustomersSupport").Select

    'Show Success SMS to the User
    MsgBox "MDs Successfully Saved as a .pdf File to 'MDs' Folder on your Desktop."

End Sub

'Check if Addin saving as a pdf is available
Private Function IsPDFLibraryInstalled() As Boolean
    IsPDFLibraryInstalled = _
        (Dir(Environ("commonprogramfiles") & _
        "\Microsoft Shared\OFFICE" & _
        Format(Val(Application.Version), "00") & _
        "\EXP_PDF.DLL") <> "")
End Function

'Create Directory folder if not exists
Function MkDir(directory As String)
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(directory) Then
        fso.CreateFolder (directory)
    End If
End Function

'Get Desktop Directory
Function GetDesktop() As String
    Dim oWSHShell As Object
    Set oWSHShell = CreateObject("WScript.Shell")
    GetDesktop = oWSHShell.SpecialFolders("Desktop")
    Set oWSHShell = Nothing
End Function

My Question is how to change it from printing out the StandardMDForm Sheet each time to

append all the resulted StandardMDSheet s into a Single pdf file ?

I tried this code within the loop but it saves each copy of the StandardMDForm for each customer in a separate file

Sheets("StandardMDForm").Select

ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FolderPath & "\" & doctorName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Create a new workbook before entering the loop, copy each completed form into that workbook, then finally select all of the sheets in the new workbook and print to PDF. https://stackoverflow.com/questions/14404650/save-multiple-sheets-to-pdf/14407986#14407986 — Tim Williams, Apr 23 '18 at 18:47

score 0 · Accepted Answer · answered Apr 23 '18 at 19:05

Compiled but not tested....

Private Sub printMDs_Click()

    Dim i As Long
    Dim FolderPath As String
    Dim shtForm As Worksheet, shtSrc As Worksheet
    Dim wbNew As Workbook, numShts As Long, numForms As Long


    Set shtForm = ThisWorkbook.Worksheets("StandardMDForm")
    Set shtSrc = ThisWorkbook.Worksheets("CustomersSupport")

    Set wbNew = Workbooks.Add()
    numShts = wbNew.Sheets.Count

    'Destination Directory to Save the PDF Files
    FolderPath = GetDesktop() & "\MDs"

    MkDir (FolderPath)

    'Loop through Rows from 5 to 84
    For i = 5 To 84
        'Check if Doctor Name is Available
        If Not IsEmpty(shtSrc.Cells(i, "I")) Then
            With shtForm
                'Doctor Details
                .Range("B4").Value = shtSrc.Cells(i, "I").Value
                .Range("B5").Value = shtSrc.Cells(i, "G").Value
                .Range("B6").Value = shtSrc.Cells(i, "H").Value
                '...
                'etc
                '...
                .Copy after:=wbNew.Sheets(wbNew.Sheets.Count) '<<<<
                numForms = numForms + 1
            End With
        End If
    Next

    'anything to print to PDF?
    If numForms > 0 Then
        'remove the empy sheets
        Application.DisplayAlerts = False
        For i = 1 To numShts
            wbNew.Sheets(i).Delete
        Next i
        Application.DisplayAlerts = True

        'save the whole file to PDF
        wbNew.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=FolderPath & "\Forms.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

        wbNew.Close False 'close without saving

        'Show Success SMS to the User
        MsgBox "MDs Successfully Saved as a .pdf File to 'MDs' Folder on your Desktop."
    End If

End Sub

thanks so much for the effort. but the result pdf contains only the first form — Ahmed Afifi, Apr 23 '18 at 19:53
Does `wbNew` contain all of the forms? (Comment out the `wbNew.Close False` to leave the file open) — Tim Williams, Apr 23 '18 at 19:56
i commented it out and run it again. wbNew is open and contains 1 sheet only (the 1st one) — Ahmed Afifi, Apr 23 '18 at 20:00
it's with the same name StandardMDForm. do you think maybe we have to rename it to be able to receive all the forms? — Ahmed Afifi, Apr 23 '18 at 20:01
i commented this out and it works perfectly now Application.DisplayAlerts = False For i = 1 To numShts wbNew.Sheets(i).Delete Next i Application.DisplayAlerts = True i don't know the reason — Ahmed Afifi, Apr 23 '18 at 20:19

Looping through an Excel Sheet copying and pasting different values and save all resulted copies to the same pdf file

1 Answers1