Excel 365 VBA to take a match of 2 factors to add to Word doc 365 table

[DThib]

Scope creep,

My boss wants the code below too not only create individual word documents but an incrementing list as a second document.
The individual documents part is working, but I cannot seem to get this to look at a common ID in a column with the same PO# and place those in the new document in an expanding table to accommodate the matches.

Any help?
I've placed my feeble attempt in the code in bold purple
It is placing each record in separate documents.

Dim wordApp As Word.Application
    Dim wDoc As Word.Document
    Dim RPs As Worksheet, i As Integer, r As Long
    Dim COr As Range, RPr As Range
    Dim cel As Range, fndRng As Range, r2 As Long, wit As Range, FR As Range
    Dim BET_T As Variant
    
     Doc_Land = "\\server\"
    
    Set wordApp = CreateObject("Word.Application")
    Set wDoc = wordApp.Documents.Open(Doc_Land & "\" & Range("N31") & ".docm")
    
    wordApp.Visible = True
    Set RPs = ThisWorkbook.Sheets("Released Product")
    With RPs
        Set RPr = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        Set RPr2 = .Range("B1", .Range("B" & .Rows.Count).End(xlUp))
    End With
        r2 = RPs.Cells(Rows.Count, "A").End(xlUp).Row
    'r = 1
    For Each cel In RPr
      Set fndRng = RPr.Find(what:=cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
         For r = 1 To r2
            If cel.Offset(r, 0) = RPs.Range("O1") Then
              If Not fndRng Is Nothing Then
                 With wDoc
                     .ContentControls(1).Range.Text = cel.Offset(r, 5).Value
                  If .ContentControls(1).Range.Text = cel.Offset(r, 5).Value Then
[B][COLOR=#800080]                    For Each wit In RPr2[/COLOR][/B]
[B][COLOR=#800080]                    Set FR = RPr2.Find(what:=wit.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)[/COLOR][/B]
[B][COLOR=#800080]                     If wit.Offset(r, 0) = matching # Then[/COLOR][/B]
                      With wDoc
                       .ContentControls(3).Range.Text = cel.Offset(r, 8).Value
                       .ContentControls(4).Range.Text = cel.Offset(r, 7).Value
                      End With
[COLOR=#800080][B]                     End If[/B][/COLOR]
[COLOR=#800080][B]                    Next[/B][/COLOR]
                  End If
                   .SaveAs Doc_Land & "\" & cel.Offset(r, 5)
                   .SaveAs Doc_Land & "\" & cel.Offset(r, 5), wdFormatPDF
                   .Close
                End With
                Set wDoc = Nothing
                Set wDoc = wordApp.Documents.Open(Doc_Land & "\" & Range("N31").Value & ".docm")
               ' wDoc.Activate
              End If
            ElseIf cel.Offset(r, 0) <> RPs.Range("O1") Then
                 'MsgBox "Current data is not present!", vbInformation + vbOKOnly, "BET Release 1001"
            End If
         Next r
    Next cel
     MsgBox "All Forms complete!", vbCritical + vbExclamation + vbOKOnly, "BET Release 1001"
    wordApp.Documents.Close
    wordApp.Quit
   
End Sub

DThib

 

[DThib]

Bump

 

[DThib]

Can anyone help??