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