How to Batch Convert Excel Data into Editable DOCX and Final PDF

Option Explicit

Sub BatchExcelToWordPdf()
    Dim xlWb As Workbook
    Dim xlWs As Worksheet
    Dim wdApp As Object ' Word.Application
    Dim wdDoc As Object ' Word.Document
    Dim fso As Object
    Dim srcPath As String, tmplPath As String, imgFolder As String
    Dim outWordFolder As String, outPdfFolder As String
    Dim lastRow As Long, i As Long
    Dim docName As String
    Dim imgPath As String
    Dim missingImages As Collection
    
    '--- Configuration ----------------------------------------------------
    srcPath = ThisWorkbook.FullName               ' current Excel file
    tmplPath = "C:\Templates\MasterTemplate.docx"   ' change as needed
    imgFolder = "C:\Images"                     ' folder with logos, signatures
    outWordFolder = "C:\Output\WORD"
    outPdfFolder = "C:\Output\PDF"
    '---------------------------------------------------------------------
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(outWordFolder) Then fso.CreateFolder outWordFolder
    If Not fso.FolderExists(outPdfFolder) Then fso.CreateFolder outPdfFolder
    If Not fso.FolderExists(imgFolder) Then
        MsgBox "Image folder not found: " & imgFolder, vbCritical
        Exit Sub
    End If
    
    Set xlWb = ThisWorkbook
    Set xlWs = xlWb.Sheets(1) ' assume first sheet holds data
    lastRow = xlWs.Cells(xlWs.Rows.Count, 1).End(xlUp).Row
    
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    Set missingImages = New Collection
    
    For i = 2 To lastRow ' start after header row
        If Trim(xlWs.Cells(i, 1).Value) = "" Then Exit For ' stop at first empty key
        
        '--- Build document name from column A (adjust as needed) ---------
        docName = CleanFileName(xlWs.Cells(i, 1).Value)
        
        Set wdDoc = wdApp.Documents.Open(tmplPath, ReadOnly:=False)
        
        '--- Populate text bookmarks --------------------------------------
        Call FillBookmark(wdDoc, "ClientName", xlWs.Cells(i, 2).Value)
        Call FillBookmark(wdDoc, "Address", xlWs.Cells(i, 3).Value)
        Call FillBookmark(wdDoc, "Date", xlWs.Cells(i, 4).Value)
        
        '--- Insert standard image (photo_logo) --------------------------
        imgPath = imgFolder & "\" & xlWs.Cells(i, 5).Value ' column 5 holds logo filename
        If fso.FileExists(imgPath) Then
            Call InsertPictureAtBookmark(wdDoc, "photo_logo", imgPath)
        Else
            missingImages.Add "Row " & i & ": " & imgPath
        End If
        
        '--- Save DOCX ---------------------------------------------------
        wdDoc.SaveAs2 fso.BuildPath(outWordFolder, docName & ".docx"), 16 ' wdFormatXMLDocument
        
        '--- Export PDF -------------------------------------------------
        wdDoc.ExportAsFixedFormat OutputFileName:=fso.BuildPath(outPdfFolder, docName & ".pdf"), ExportFormat:=17 ' wdExportFormatPDF
        
        wdDoc.Close SaveChanges:=False
    Next i
    
    wdApp.Quit
    Set wdApp = Nothing
    
    If missingImages.Count > 0 Then
        Dim msg As String, itm As Variant
        msg = "The following images were not found and were skipped:" & vbCrLf
        For Each itm In missingImages
            msg = msg & itm & vbCrLf
        Next itm
        MsgBox msg, vbExclamation, "Missing images"
    Else
        MsgBox "Batch conversion completed successfully.", vbInformation
    End If
End Sub

'--- Helper to clean file names -------------------------------------------
Private Function CleanFileName(s As String) As String
    Dim illegal As Variant
    illegal = Array("/", "\\", ":", "*", "?", """, "<", ">", "|")
    Dim i As Long
    For i = LBound(illegal) To UBound(illegal)
        s = Replace(s, illegal(i), "_")
    Next i
    CleanFileName = Trim(s)
End Function

'--- Fill a bookmark with text while preserving the bookmark ----------
Private Sub FillBookmark(doc As Object, bmName As String, txt As Variant)
    On Error Resume Next
    If Not IsEmpty(txt) Then
        Dim bmRange As Object
        Set bmRange = doc.Bookmarks(bmName).Range
        bmRange.Text = txt
        ' Re‑add the bookmark so it is not lost after the text replacement
        doc.Bookmarks.Add bmName, bmRange
    End If
    On Error GoTo 0
End Sub

'--- Insert picture at a bookmark -----------------------------------------
Private Sub InsertPictureAtBookmark(doc As Object, bmName As String, picPath As String)
    On Error Resume Next
    Dim rng As Object
    Set rng = doc.Bookmarks(bmName).Range
    doc.InlineShapes.AddPicture FileName:=picPath, LinkToFile:=False, SaveWithDocument:=True, Range:=rng
    On Error GoTo 0
End Sub