Public Sub MakeFDF() Dim TurnOn As Boolean If Application.ScreenUpdating = True Then 'Turn off screen updating to make it faster Call Update_off TurnOn = True Else: TurnOn = False End If Dim sFileHeader As String Dim sFileFooter As String Dim sFileFields, sFileFieldItem, sFileFieldMaterial, sFileFieldProduct, sFileFieldManufacture, sFileFieldRAM, sFileFieldRamCode As String Dim sFileName As String Dim sTmp As String Dim lngFileNum As Long Dim lrow As ListRow Dim BidNum, Qty, Unit, BidItem, Product, Manufacturer, Acceptance, RamNo, AppCode, PayItem As String Dim FNRSavePath, FNRSaveFile, PDFTemplateFile, fdfName As String Dim ItemRow, lastrow, LastRow2 As Long 'Define where data you are going to use to fill out PDF forms Dim Contract_No, Project_Name, Project_No As String Contract_No = Worksheets("Rom").Range("L5").Value Project_Name = Worksheets("Rom").Range("G5").Value Project_No = Worksheets("Rom").Range("L6").Value Dim tblRom As ListObject 'I used a Table for most of my data Set tblRom = Worksheets("Rom").ListObjects("ROM") lastrow = tblRom.DataBodyRange.Rows.Count 'Last Row 'LastRow2 = Worksheets("Rom").Range("A9999").End(xlUp).Row 'Last Row without referencing table PDFTemplateFile = "P:\Public Works\01 Administration\FORMS\04 Construction\08 Inspection Docs\Field Note Record-Grid 4-22.pdf" 'Template File Name and location 'setting default save path for pdfs and check if folder exist with browsing for location as a pop up if location does not work FNRSavePath = ThisWorkbook.Path ChDrive "P" ChDir FNRSavePath ChDir ".." FNRSavePath = CurDir ChDir ".." FNRSavePath = CurDir FNRSavePath = FNRSavePath & "\05 Inspector Documents\02 Field Note Records\DATA" FNRSavePath = CheckFolderExists(FNRSavePath, " Inspector Documents FNR DATA ") ' this will be what shows in pop up to browse for a folder location If FNRSavePath = "" Then Exit Sub End If 'setting up counters to deal with looping through Dim counter, counter2, endnumber, iFields, pagecount, i As Integer endnumber = 9 counter = 1 counter2 = 1 iFields = 1 pagecount = 0 For Each lrow In tblRom.ListRows BidNum = Intersect(lrow.Range, tblRom.ListColumns("Bid Item").Range).Value Qty = Intersect(lrow.Range, tblRom.ListColumns("Item Qty.").Range).Value Unit = Intersect(lrow.Range, tblRom.ListColumns("Unit").Range).Value BidItem = Intersect(lrow.Range, tblRom.ListColumns("Material").Range).Value Product = Intersect(lrow.Range, tblRom.ListColumns("Product").Range).Value Manufacturer = Intersect(lrow.Range, tblRom.ListColumns("Manufacturer").Range).Value Acceptance = Intersect(lrow.Range, tblRom.ListColumns("Acceptance").Range).Value 'Spec = Intersect(lrow.Range, tblRom.ListColumns("Specification Section").Range).Value ' not needed column RamNo = Intersect(lrow.Range, tblRom.ListColumns("RAM No.").Range).Value AppCode = Intersect(lrow.Range, tblRom.ListColumns("RAM/QPL Approval Code").Range).Value If Intersect(lrow.Range, tblRom.ListColumns("Bid Item").Range).Interior.Color = RGB(214, 133, 255) Then GoTo Line7 'skipping items that are not used If Intersect(lrow.Range, tblRom.ListColumns("Bid Item").Range).Interior.Color = RGB(255, 117, 117) Then GoTo Line7 'skipping items that are rejected Line5A: If counter < endnumber Then GoTo Line5 Else GoTo Line6 Line5: If Int(BidNum) = BidNum Then GoTo line1 Else GoTo line2 line1: If counter > 1 Then GoTo Line8 PayItem = BidNum FNRSaveFile = FNRSavePath & "\" & PayItem & ".pdf" If (Dir(FNRSaveFile) <> "") Then Kill FNRSaveFile End If Call FileCopy(PDFTemplateFile, FNRSaveFile) 'Copy Template fdfName = PayItem & ".pdf" sFileHeader = "%FDF-1.2" & vbCrLf & _ "%âãÏÓ" & vbCrLf & _ "1 0 obj<>>>" & vbCrLf & _ "endobj" & vbCrLf & _ "2 0 obj[" & vbCrLf sFileFooter = "]" & vbCrLf & _ "endobj" & vbCrLf & _ "trailer" & vbCrLf & _ "<>" & vbCrLf & _ "%%EO" sFileFields = "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf sFileFields = sFileFields & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf sFileFields = sFileFields & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf '"<>" & vbCrLf 'Static on Sheet sFileFields = Replace(sFileFields, "---Contract_No---", Contract_No) sFileFields = Replace(sFileFields, "---Project_Name---", Project_Name) sFileFields = Replace(sFileFields, "---Project_No---", Project_No) If Len(Acceptance) = 0 Then GoTo Line3 Else GoTo Line4 Line8: For i = 1 To 8 sFileFields = Replace(sFileFields, "---Item" & i & "---", "") sFileFields = Replace(sFileFields, "---Material" & i & "---", "") sFileFields = Replace(sFileFields, "---Product" & i & "---", "") sFileFields = Replace(sFileFields, "---Manufacturer" & i & "---", "") sFileFields = Replace(sFileFields, "---RAM" & i & "---", "") sFileFields = Replace(sFileFields, "---RamCode" & i & "---", "") 'sFileFields = Replace(sFileFields, "---Acceptance" & i & "---", "") Next i 'Save the item by the bid number sTmp = sFileHeader & sFileFields & sFileFooter sFileName = FNRSavePath & "\_" & PayItem & ".fdf" If (Dir(sFileName) <> "") Then Kill sFileName End If lngFileNum = FreeFile Open sFileName For Output As lngFileNum Print #lngFileNum, sTmp Close #lngFileNum DoEvents counter = 1 counter2 = 1 iFields = 1 pagecount = 0 GoTo line1 line2: If Len(BidNum) > 6 Then BidNum = Int(BidNum) sFileFields = Replace(sFileFields, "---Item" & iFields & "---", BidNum) sFileFields = Replace(sFileFields, "---Material" & iFields & "---", BidItem) sFileFields = Replace(sFileFields, "---Product" & iFields & "---", Product) sFileFields = Replace(sFileFields, "---Manufacturer" & iFields & "---", Manufacturer) sFileFields = Replace(sFileFields, "---RAM" & iFields & "---", RamNo) sFileFields = Replace(sFileFields, "---RamCode" & iFields & "---", AppCode) 'sFileFields = Replace(sFileFields, "---Acceptance" & iFields & "---", Acceptance) iFields = iFields + 1 counter = counter + 1 GoTo Line7 Line3: 'Dynamic only for Pay Item sFileFields = Replace(sFileFields, "---PayItem1---", PayItem) sFileFields = Replace(sFileFields, "---Item_Description1---", BidItem) sFileFields = Replace(sFileFields, "---Unit1---", Unit) counter = counter + 1 GoTo Line7 Line4: sFileFields = Replace(sFileFields, "---Item" & iFields & "---", BidNum) sFileFields = Replace(sFileFields, "---Material" & iFields & "---", BidItem) sFileFields = Replace(sFileFields, "---Product" & iFields & "---", Product) sFileFields = Replace(sFileFields, "---Manufacturer" & iFields & "---", Manufacturer) sFileFields = Replace(sFileFields, "---RAM" & iFields & "---", RamNo) sFileFields = Replace(sFileFields, "---RamCode" & iFields & "---", AppCode) 'sFileFields = Replace(sFileFields, "---Acceptance" & iFields & "---", Acceptance) iFields = iFields + 1 GoTo Line3 Line6: counter2 = counter2 + 1 If Int(BidNum) <> BidNum And counter2 > 1 Then GoTo Line6A Else GoTo Line8 Line6A: 'Save the item by the bid number sTmp = sFileHeader & sFileFields & sFileFooter sFileName = FNRSavePath & "\_" & PayItem & ".fdf" If (Dir(sFileName) <> "") Then Kill sFileName End If 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) counter = 1 iFields = 1 pagecount = pagecount + 1 PayItem = PayItem & "_" & pagecount FNRSaveFile = FNRSavePath & "\" & PayItem & ".pdf" If (Dir(FNRSaveFile) <> "") Then Kill FNRSaveFile End If Call FileCopy(PDFTemplateFile, FNRSaveFile) 'Copy Template fdfName = PayItem & ".pdf" sFileHeader = "%FDF-1.2" & vbCrLf & _ "%âãÏÓ" & vbCrLf & _ "1 0 obj<>>>" & vbCrLf & _ "endobj" & vbCrLf & _ "2 0 obj[" & vbCrLf sFileFooter = "]" & vbCrLf & _ "endobj" & vbCrLf & _ "trailer" & vbCrLf & _ "<>" & vbCrLf & _ "%%EO" sFileFields = "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf sFileFields = sFileFields & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf sFileFields = sFileFields & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf & _ "<>" & vbCrLf '"<>" & vbCrLf 'Static on Sheet sFileFields = Replace(sFileFields, "---Contract_No---", Contract_No) sFileFields = Replace(sFileFields, "---Project_Name---", Project_Name) sFileFields = Replace(sFileFields, "---Project_No---", Project_No) GoTo line2 Line7: Next lrow For i = 1 To 8 sFileFields = Replace(sFileFields, "---Item" & i & "---", "") sFileFields = Replace(sFileFields, "---Material" & i & "---", "") sFileFields = Replace(sFileFields, "---Product" & i & "---", "") sFileFields = Replace(sFileFields, "---Manufacturer" & i & "---", "") sFileFields = Replace(sFileFields, "---RAM" & i & "---", "") sFileFields = Replace(sFileFields, "---RamCode" & i & "---", "") 'sFileFields = Replace(sFileFields, "---Acceptance" & i & "---", "") Next i 'Save the item by the bid number sTmp = sFileHeader & sFileFields & sFileFooter sFileName = FNRSavePath & "\_" & PayItem & ".fdf" If (Dir(sFileName) <> "") Then Kill sFileName End If lngFileNum = FreeFile Open sFileName For Output As lngFileNum Print #lngFileNum, sTmp Close #lngFileNum DoEvents If TurnOn = True Then Call Update_on Else End If End Sub Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean Dim sht As Worksheet If wb Is Nothing Then Set wb = ThisWorkbook On Error Resume Next Set sht = wb.Sheets(shtName) On Error GoTo 0 WorksheetExists = Not sht Is Nothing End Function Function CheckFolderExists(ByVal strFolderPath As String, ByVal strFolderName As String) As String 'Dim strFolderName As String Dim strFolderExists As String 'strFolderName = "C:\Users\Nikola\Desktop\VBA articles\Test Folder\" strFolderExists = Dir(strFolderPath, vbDirectory) If strFolderExists = "" Then MsgBox "Select Project " & strFolderName & " Folder", , "Instructions" 'MsgBox "The selected folder doesn't exist" Dim PDFFldr As FileDialog Set PDFFldr = Application.FileDialog(msoFileDialogFolderPicker) With PDFFldr .Title = "Select the" & strFolderName & "Folder" If .Show <> -1 Then GoTo NoSel: 'wsROM.Range("AE7").Value = .SelectedItems(1) CheckFolderExists = .SelectedItems(1) End With Exit Function Else Exit Function End If NoSel: MsgBox "The selected" & strFolderName & "folder doesn't exist please try again" CheckFolderExists = "" End Function Sub Update_off() With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With ActiveWindow.View = xlNormalView ActiveSheet.DisplayPageBreaks = False End Sub Sub Update_on() With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With ActiveWindow.View = xlPageBreakPreview ActiveSheet.DisplayPageBreaks = True ActiveWindow.Zoom = 90 End Sub Function Max(ParamArray values() As Variant) As Variant Dim maxValue, Value As Variant maxValue = values(0) For Each Value In values If Value > maxValue Then maxValue = Value Next Max = maxValue End Function Function Min(ParamArray values() As Variant) As Variant Dim minValue, Value As Variant minValue = values(0) For Each Value In values If Value < minValue Then minValue = Value Next Min = minValue End Function Function onlyDigits(s As String) As String ' Variables needed (remember to use "option explicit"). ' Dim retval As String ' This is the return string. ' Dim i As Integer ' Counter for character position. ' ' Initialise return string to empty ' retval = "" ' For every character in input string, copy digits to ' ' return string. ' For i = 1 To Len(s) If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then retval = retval + Mid(s, i, 1) End If Next ' Then return the return string. ' onlyDigits = retval End Function Sub DeleteFile(ByVal FileToDelete As String) If FileExists(FileToDelete) Then 'See above ' First remove readonly attribute, if set SetAttr FileToDelete, vbNormal ' Then delete the file Kill FileToDelete End If End Sub Function FileExists(ByVal FileToTest As String) As Boolean FileExists = (Dir(FileToTest) <> "") End Function