Copy and Paste Page to Each Row in Excel

[gmayor]

Without the original document it is difficult to test, but in theory the following should work. This creates a new document based on the original document, copies the last page of that document to the end of that document and writes the values required into the tables

Sub Create_Tests_Document()
Dim LV_WordApp As Object
Dim wdDoc As Object
Dim oTable As Object
Dim oRng1 As Object
Dim oRng2 As Object
Dim oCell As Object
Dim LV_RowsCounter As Integer
Dim LV_RowIndex As Integer

    LV_RowsCounter = ActiveSheet.UsedRange.Rows.Count
    Set LV_WordApp = CreateObject("Word.Application")
    LV_WordApp.Visible = True
    Set wdDoc = LV_WordApp.Documents.Add("C:\Users\douglasmmm\desktop\MyFile.docx")
    Set oRng1 = wdDoc.Range
    oRng1.collapse 0
    oRng1.Select
    wdDoc.Bookmarks("\Page").Range.Copy
    For LV_RowIndex = 2 To LV_RowsCounter
        Set oRng2 = wdDoc.Range
        oRng2.collapse 0
        oRng2.InsertBreak 2
        Set oRng2 = wdDoc.Range
        oRng2.collapse 0
        oRng2.Paste
        Set oTable = wdDoc.tables(wdDoc.tables.Count)
        With oTable
            Set oCell = oTable.Cell(2, 1).Range
            oCell.End = oCell.End - 1
            oCell.Text = Cells(LV_RowIndex, 2).Value
            Set oCell = oTable.Cell(2, 2).Range
            oCell.End = oCell.End - 1
            oCell.Text = Cells(LV_RowIndex, 10).Value
        End With
        DoEvents
    Next LV_RowIndex
End Sub