How to Standardize Repeating Business Documents Across Teams

Sub GenerateDocuments()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim wdApp As Object ' Word.Application
    Dim wdDoc As Object ' Word.Document
    Dim templatePath As String
    Dim outputWordFolder As String, outputPdfFolder As String
    Dim imgFolder As String
    Dim logMsg As String

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

    templatePath = "C:\Templates\StandardDocTemplate.docx"
    outputWordFolder = "C:\Generated\WORD"
    outputPdfFolder = "C:\Generated\PDF"
    imgFolder = "C:\Images"

    ' Ensure output folders exist
    If Dir(outputWordFolder, vbDirectory) = "" Then MkDir outputWordFolder
    If Dir(outputPdfFolder, vbDirectory) = "" Then MkDir outputPdfFolder

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)

    For i = 2 To lastRow ' assuming header row
        Dim docName As String
        docName = ws.Cells(i, "A").Value ' Column A holds a unique identifier
        If docName = "" Then GoTo NextRow

        ' Clone the template for this row
        wdDoc.Activate
        wdDoc.Content.Copy
        Dim newDoc As Object
        Set newDoc = wdApp.Documents.Add
        newDoc.Content.Paste

        ' Fill bookmarks
        Dim bm As Object
        For Each bm In newDoc.Bookmarks
            Dim colIdx As Long
            colIdx = Application.Match(bm.Name, ws.Rows(1), 0)
            If Not IsError(colIdx) Then
                newDoc.Bookmarks(bm.Name).Range.Text = ws.Cells(i, colIdx).Value
            End If
        Next bm

        ' Insert special images
        InsertTaggedImage newDoc, "photo_logo", ws.Cells(i, "B").Value, imgFolder
        InsertTaggedImage newDoc, "photo_signature", ws.Cells(i, "C").Value, imgFolder
        InsertTaggedImage newDoc, "photo_stamp", ws.Cells(i, "D").Value, imgFolder

        ' Save DOCX
        Dim docPath As String
        docPath = outputWordFolder & "\" & docName & ".docx"
        newDoc.SaveAs2 docPath, 16 ' wdFormatXMLDocument

        ' Export PDF
        Dim pdfPath As String
        pdfPath = outputPdfFolder & "\" & docName & ".pdf"
        newDoc.ExportAsFixedFormat OutputFileName:=pdfPath, ExportFormat:=17 ' wdExportFormatPDF

        newDoc.Close False
NextRow:
    Next i

    wdDoc.Close False
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    MsgBox "Document generation completed.", vbInformation
End Sub

Sub InsertTaggedImage(ByRef doc As Object, tagName As String, tagValue As String, imgFolder As String)
    On Error Resume Next
    Dim imgPath As String
    imgPath = imgFolder & "\" & tagValue
    If Dir(imgPath) <> "" Then
        Dim bm As Object
        Set bm = doc.Bookmarks(tagName)
        If Not bm Is Nothing Then
            bm.Range.InlineShapes.AddPicture Filename:=imgPath, LinkToFile:=False, SaveWithDocument:=True
        End If
    Else
        ' Log missing image – in a real macro you might write to a log file
    End If
    On Error GoTo 0
End Sub