vbaexcelmacrosfdf

Excel VBA Write FDF file using Variables


I'm a therapist who has to write billing sheets. It's a pain in the neck to write them out one by one, so I have a macro that I modified to suit my needs. It takes an excel file and writes an FDF file which then autofills a PDF file. All I need to do is fill out the excel file and it can autogenerate the PDF file.

The trouble I have is that sometimes I have 3 clients, or 5, or 7. I want to write a macro that takes a number that will be specified in the sheet, and create an FDF for that amount of clients.

So I will have 8 PDF files. Billing1, Billin2, etc. Based on the number in the sheet, I want the macro to create an FDF file filling the values of Client1 Date1 Client2 Date2, etc. Right now it's only set up to do 6 clients at once and it's static.

Here is the code I have now:

    Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_NORMAL = 1
Public Const PDF_FILE = "Billing.pdf"


Public Sub MakeFDF()

    Dim sFileHeader As String
    Dim sFileFooter As String
    Dim sFileFields As String
    Dim sFileName As String
    Dim sTmp As String
    Dim lngFileNum As Long
    Dim vClient As Variant


    ' Builds string for contents of FDF file and then writes file to workbook folder.
    On Error GoTo ErrorHandler

    sFileHeader = "%FDF-1.2" & vbCrLf & _
                  "%âãÏÓ" & vbCrLf & _
                  "1 0 obj<</FDF<</F(" & PDF_FILE & ")/Fields 2 0 R>>>>" & vbCrLf & _
                  "endobj" & vbCrLf & _
                  "2 0 obj[" & vbCrLf

    sFileFooter = "]" & vbCrLf & _
                  "endobj" & vbCrLf & _
                  "trailer" & vbCrLf & _
                  "<</Root 1 0 R>>" & vbCrLf & _
                  "%%EO"


    sFileFields = "<</T(Date1)/V(---Date1---)>>" & vbCrLf & _
                  "<</T(Date2)/V(---Date2---)>>" & vbCrLf & _
                  "<</T(Date3)/V(---Date3---)>>" & vbCrLf & _
                  "<</T(Date4)/V(---Date4---)>>" & vbCrLf & _
                  "<</T(Date5)/V(---Date5---)>>" & vbCrLf & _
                  "<</T(Date6)/V(---Date6---)>>" & vbCrLf & _
                  "<</T(Name1)/V(---Name1---)>>" & vbCrLf & _
                  "<</T(Name2)/V(---Name2---)>>" & vbCrLf & _
                  "<</T(Name3)/V(---Name3---)>>" & vbCrLf & _
                  "<</T(Name4)/V(---Name4---)>>" & vbCrLf & _
                  "<</T(Name5)/V(---Name5---)>>" & vbCrLf & _
                  "<</T(Name6)/V(---Name6---)>>" & vbCrLf

    Range("A5").Select

    vClient = Range(Selection.Row & ":" & Selection.Row)

    sFileFields = Replace(sFileFields, "---Date1---", vClient(1, 9))
    sFileFields = Replace(sFileFields, "---Date2---", vClient(1, 10))
    sFileFields = Replace(sFileFields, "---Date3---", vClient(1, 11))
    sFileFields = Replace(sFileFields, "---Date4---", vClient(1, 12))
    sFileFields = Replace(sFileFields, "---Date5---", vClient(1, 13))
    sFileFields = Replace(sFileFields, "---Date6---", vClient(1, 14))
    sFileFields = Replace(sFileFields, "---Name1---", vClient(1, 15))
    sFileFields = Replace(sFileFields, "---Name2---", vClient(1, 16))
    sFileFields = Replace(sFileFields, "---Name3---", vClient(1, 17))
    sFileFields = Replace(sFileFields, "---Name4---", vClient(1, 18))
    sFileFields = Replace(sFileFields, "---Name5---", vClient(1, 19))
    sFileFields = Replace(sFileFields, "---Name6---", vClient(1, 20))

    sTmp = sFileHeader & sFileFields & sFileFooter


    ' Write FDF file to disk
    sFileName = "BillingMultipule"
    sFileName = ActiveWorkbook.Path & "\" & sFileName & ".fdf"
    lngFileNum = FreeFile
    Open sFileName For Output As lngFileNum
    Print #lngFileNum, sTmp
    Close #lngFileNum
    DoEvents

    ' Open FDF file as PDF
    ShellExecute vbNull, "open", sFileName, vbNull, vbNull, SW_NORMAL
    Exit Sub

ErrorHandler:
    MsgBox "MakeFDF Error: " + Str(Err.Number) + " " + Err.Description + " " + Err.Source

End Sub

Solution

  • Use a loop

    Dim iFields as Integer
    For iFields = 1 to Worksheets("Sheet1").Range("A5").Value2 'assumes this is where you have number of clients.
    
       sFileFieldDates = sFileFieldDates & "<</T(Date" & iFields & ")/V(---Date" & iFields & "---)>>" & vbCrLf
       sFileFieldNames = sFileFieldNames & "<</T(Name" & iFields & ")/V(---Name" & iFields & "---)>>" & vbCrLf
    
    Next 
    
    'you most likely need to use Mid or Trim or something to get rid of extra spacing or characters before combining the names
    sFileFields = sFileFieldDates & sFileFieldNames
    

    Then

    For iFields = 1 to Worksheets("Sheet1").Range("A5").Value2
       sFileFields = Replace(sFileFields, "---Date" & iFields & "---", vClient(1, iFields +9))
       sFileFields = Replace(sFileFields, "---Name" & iFields & "---", vClient(1, iFields +15))
    Next