Excel → Word → PDF Workflow for Legal Intake Documents

Option Explicit

Sub GenerateIntakeDocs()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wordApp As Object
    Dim doc As Object
    Dim templatePath As String
    Dim imageFolder As String
    Dim outputFolder As String
    Dim wordFolder As String
    Dim pdfFolder As String
    Dim lastRow As Long, i As Long
    Dim cellValue As Variant
    Dim bookmarkName As String
    Dim imgPath As String
    Dim photoCol As Long, nameCol As Long

    '--- configuration -------------------------------------------------------
    templatePath = "C:\Templates\IntakeTemplate.docx"   ' adjust path
    imageFolder = "C:\IntakeImages"                    ' folder with photos
    outputFolder = ThisWorkbook.Path & "\Generated"      ' base output folder
    wordFolder = outputFolder & "\WORD"
    pdfFolder = outputFolder & "\PDF"
    '-----------------------------------------------------------------------

    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' locate required columns; fail gracefully if missing
    photoCol = 0
    nameCol = 0
    Dim hdrCell As Range
    For Each hdrCell In ws.Rows(1).Cells
        Select Case Trim(LCase(hdrCell.Value))
            Case "photo_signature"
                photoCol = hdrCell.Column
            Case "clientname"
                nameCol = hdrCell.Column
        End Select
    Next hdrCell
    If photoCol = 0 Then Debug.Print "Warning: photo_signature column not found. Image insertion will be skipped."
    If nameCol = 0 Then
        MsgBox "Error: ClientName column is required for file naming.", vbCritical
        Exit Sub
    End If

    ' ensure output folders exist
    If Dir(wordFolder, vbDirectory) = "" Then MkDir wordFolder
    If Dir(pdfFolder, vbDirectory) = "" Then MkDir pdfFolder

    ' start Word
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False

    For i = 2 To lastRow ' assume row 1 has headers
        Set doc = wordApp.Documents.Open(templatePath, ReadOnly:=False)

        ' loop through each header column to fill bookmarks
        Dim col As Long
        For col = 1 To ws.UsedRange.Columns.Count
            bookmarkName = ws.Cells(1, col).Value
            cellValue = ws.Cells(i, col).Value
            If Not IsEmpty(bookmarkName) Then
                On Error Resume Next
                doc.Bookmarks(bookmarkName).Range.Text = CStr(cellValue)
                On Error GoTo 0
            End If
        Next col

        ' handle optional signature image if column exists and value present
        If photoCol > 0 Then
            imgPath = Trim(ws.Cells(i, photoCol).Value)
            If Len(imgPath) > 0 Then
                imgPath = imageFolder & "\" & imgPath
                If Dir(imgPath) <> "" Then
                    Dim bmRange As Object
                    Set bmRange = doc.Bookmarks("photo_signature").Range
                    bmRange.InlineShapes.AddPicture FileName:=imgPath, LinkToFile:=False, SaveWithDocument:=True
                Else
                    Debug.Print "Missing image for row " & i & ": " & imgPath
                End If
            End If
        End If

        ' save Word file using client name
        Dim docName As String
        docName = ws.Cells(i, nameCol).Value & "_Intake.docx"
        doc.SaveAs2 Filename:=wordFolder & "\" & docName, FileFormat:=16 ' wdFormatXMLDocument

        ' export PDF
        doc.ExportAsFixedFormat OutputFileName:=pdfFolder & "\" & Replace(docName, ".docx", ".pdf"), ExportFormat:=17 ' wdExportFormatPDF

        doc.Close SaveChanges:=False
    Next i

    wordApp.Quit
    Set wordApp = Nothing
    MsgBox "Intake documents generated: " & (lastRow - 1) & " records.", vbInformation
End Sub