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

DThib

Active Member
Joined
Mar 19, 2010
Messages
429
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.

Code:
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
 

Some videos you may like

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

Watch MrExcel Video

Forum statistics

Threads
1,122,261
Messages
5,595,133
Members
413,971
Latest member
User786

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top