Microsoft Office Forums - View Single Post - Mail Merge - Covering Letter with multiple additional pages not always the same amount

gmayor · 10-11-2015, 11:33 PM

This is not the simplest of tasks, however it can be done. Start by bookmarking all the merge fields in the merge document and make a note of the bookmark names. If you have used the same merge field more than once, then as bookmark names must be unique, provide a unique name for each occasion.

If you have not already done so, save the 'form' as a word document.

Then the following macro should produce a document each time the value changes in column A of the worksheet, with an added form for each similar value in column A. Clearly the data must be sorted on column A. If the ID data is not in column A then change the macro to reflect the appropriate column in the line

If Not .Range("A" & i) = .Range("A" & i - 1) Then

Change the lines that reflect the data file and form document paths/names.

Change the line FillBM "BKName", .Range("A" & i) to reflect the bookmark name and the column that contains the data associated with that bookmark

You will need to repeat the line, with the appropriate values, for each bookmark in the document.

http://www.gmayor.com/installing_macro.htm

Code:

Option Explicit

Sub MergeWithForms()
Dim xlApp As Object
Dim xlBook As Object
Dim oDoc As Document
Dim oRng As Range
Dim strFname As String
Dim LastRow As Long, i As Long

Const strWorkbookname As String = "C:\Path\Data.xlsx" 'The path to the worksheet
Const strForm As String = "C:\Path\Form.docx" 'The path to the form document

    ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument
    ActiveDocument.Save
    If Len(ActiveDocument.Path) = 0 Then
        MsgBox "Cancelled"
        GoTo lbl_Exit
    End If
    strFname = ActiveDocument.FullName
    ActiveDocument.Close 0
    Set oDoc = Documents.Add(strFname)
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0

    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Open(Filename:=strWorkbookname)
    LastRow = xlBook.Sheets(1).Range("A" & xlBook.Sheets(1).Rows.Count).End(-4162).Row
    With xlBook.Sheets(1)        'assumes the data is on the first sheet
        For i = 2 To LastRow        'ignore the header row
            If Not .Range("A" & i) = .Range("A" & i - 1) Then
                FillBM "BKName", .Range("A" & i)
                'Repeat FillBM for each bookmark
                                
                If i > 2 Then
                    Set oRng = oDoc.Range
                    oRng.Collapse 0
                    oRng.InsertBreak wdSectionBreakNextPage
                    Set oRng = oDoc.Range
                    oRng.Collapse 0
                    oRng.InsertFile strFname
                    FillBM "BKName", .Range("A" & i)
                End If
            End If
            Set oRng = oDoc.Range
            oRng.Collapse 0
            oRng.InsertBreak wdPageBreak
            Set oRng = oDoc.Range
            oRng.Collapse 0
            oRng.InsertFile strForm
        Next i
    End With
lbl_Exit:
    Exit Sub
End Sub


Private Sub FillBM(strBMName As String, strValue As String)
'Graham Mayor
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strBMName).Range
        oRng.Text = strValue
        .Bookmarks(strBMName).Delete
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub