Question : Word Mail Merge automated from Access with one-to-many layout

I have a routine automated from Access that loops through the "One" recordset and merges the fields from the recordsource to one Word document for each record. I am now re-writing the routine to print several Word documents for a single "One" record, so the new code will open a recordset of one, and loop through a recordset of document names and paths, outputting one document each time through the loop. However, several of those documents have tables in which "Many" records need to be entered. I can identify these documents in the document name (add "ZZZ" to each doc name and check it with Instr), but I don't know how to automate the insertion of the subrecords. I have reviewed previous answers on this subject, but they have been too brief for me to follow. For example, the most promising looking one using a Range in Word, along with Bookmarks, doesn't tell how to set up the Word doc to work with the code. Can anyone dummy it down for me?

Here's my original code, if that helps:

Do Until .EOF
strSourceSQL = "SELECT vwContractInfo.* FROM vwContractInfo WHERE bmID=" & lngBidID
Set objWordDoc = objWordApp.Documents.Open(strMergeDoc)

' Set the mail merge data source and run the merge
With objWordDoc.MailMerge
.OpenDataSource Name:="", Connection:=strConnection, SQLStatement:=strSourceSQL
.Destination = wdSendToNewDocument
.Execute
End With

'the new document created by MailMerge becomes the ActiveDocument. Save it and close.
strResultDoc = strResultPath & !jobno & " Subcontract" & !ContractNumber & ".doc"
With objWordApp.ActiveDocument
.SaveAs strResultDoc
.Close wdDoNotSaveChanges
End With

'Close the MailMerge main document
objWordDoc.Close wdDoNotSaveChanges
Set objWordDoc = Nothing

.MoveNext
Loop

Answer : Word Mail Merge automated from Access with one-to-many layout

I don't think that there are too many obscure objects here. There are a few points though.
In this code the datasource is already set in the document, so the OpenDataSource is not used.
Instead of running manu mailmerges, one per record, we run one and execute it once for each record. In both cases your code is just as valid.
It's midnight here, so I won't be following up for at least eight hours.

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:



Sub DoMerge()
    Dim strMergeDoc As String
    Dim objWordApp As Word.Application
    Dim ObjWordDoc As Word.Document
    Dim strResultDoc As String
    Dim strResultPath As String
    Dim r As Integer
    Dim dbs As DAO.Database
    Dim rs As DAO.Recordset
    Dim strSubSQL As String
    Dim tbl As Word.Table
    Dim rw As Word.Row
    Dim f As Integer
    
    Set dbs = CurrentDb
    strMergeDoc = "C:\Documents and Settings\Graham Skan\My Documents\MMsubMain.doc"
    'Do Until .EOF
    'strSourceSQL = "SELECT vwContractInfo.* FROM vwContractInfo WHERE bmID=" & lngBidID
    Set objWordApp = Word.Application
    objWordApp.Visible = True
    Set ObjWordDoc = objWordApp.Documents.Open(strMergeDoc)
    With ObjWordDoc.MailMerge
        For r = 1 To .DataSource.RecordCount
            '.OpenDataSource Name:="", Connection:=strConnection, SQLStatement:=strSourceSQL
            .Destination = wdSendToNewDocument
            .DataSource.FirstRecord = r
            .DataSource.LastRecord = r
            .Execute
            
            'sub processing
            .DataSource.ActiveRecord = r
            If InStr(.DataSource.DataFields("Main1"), "ZZZ") > 0 Then
                'create a recordset of subsiduary items belonging to the main record
                strSubSQL = "SELECT tblSub.Sub1, tblSub.Sub2 " & _
                            "From tblSub " & _
                            "WHERE ((tblSub.[Main ID])=" & .DataSource.DataFields("Main_ID") & "); "
                
                Set rs = dbs.OpenRecordset(strSubSQL, dbOpenDynaset)
                Set tbl = ActiveDocument.Tables(1)
                Do Until rs.EOF
                    Set rw = tbl.Rows.Add
                    For f = 0 To rs.Fields.Count - 1
                        rw.Cells(f + 1).Range.Text = rs.Fields(f).Value
                    Next f
                    rs.MoveNext
                Loop
                rs.Close
            End If
            'the new document created by MailMerge becomes the ActiveDocument.  Save it and close.
            'strResultDoc = strResultPath & !jobno & "  Subcontract" & !ContractNumber & ".doc"
            strResultDoc = "MMsubMainResult" & r & ".doc"
            With objWordApp.ActiveDocument
                .SaveAs strResultDoc
                .Close wdDoNotSaveChanges
            End With
        Next r
    End With
    
    'Close the MailMerge main document
    ObjWordDoc.Close wdDoNotSaveChanges
    Set ObjWordDoc = Nothing
    
    '.MoveNext
    'Loop
End Sub

Open in New Window

Select All