Search code examples
excelvbams-wordmailmerge

Mail merge with looping/grouping


I have an Excel table, which I use to do a mail merge into word.

Excel Table

The mail merge is done through this code

'starting the mail merge for the main body of the report
Set wdDoc = wdApp.Documents.Open(fNameW)
wdDoc.Activate
wdDoc.MailMerge.OpenDataSource Name:=(fNameE), Revert:=False, Connection:="Entire Spreadsheet", SQLStatement:="SELECT * FROM `'Table of Recommendations$'`", SQLStatement1:=""
With wdDoc.MailMerge
    .MainDocumentType = wdFormLetters
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    End With
    .Execute
    
    For Each wd In ActiveDocument.StoryRanges
    With wd.Find
        .Text = "(blank)"
        .Replacement.Text = ""
        .Forward = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
    
    With wd.Find
        .Text = "^b"
        .Wrap = wdFindContinue
        While .Execute
            wd.Delete
            wd.InsertParagraph
        Wend
    End With
    Next wd

And this is the output I get:

enter image description here

Now, my question. What I would like to achieve is that recommendation number (b) gets inserted in the first table, just under recommendation number (a), based on the fact that the two recommendations arise from the same issue Country Cooperation. In other words, the merge process should loop through the Excel table and if the issue is the same, it should group the recommendations together, omit the blank cells, and not generate the second table. Do you think this is possible? If yes, can you point me in the right direction? I have searched allover the internet but have not been able to find any solution. Thank you.


Solution

  • I have solved my problem following the suggestions given by @macropod. Using the guideline available at https://www.msofficeforums.com/mail-merge/38721-microsoft-word-catalogue-directory-mailmerge-tutorial.html, I was able to sort the issue out. I set-up the mail merge template as described in page 4 of the afire guideline, added the table joiner macro described in pages 20/21 of the afore guidelines and solved my issue. Below a sample of the code I wrote:

    'starting the mail merge for the main body of the report
    With wdApp 'launching Ms Word
    fNameW = "C:\Users\" & uName & "\OneDrive...\Main Body.dotx"
    .Visible = True
    .Documents.Open fNameW, , ReadOnly
    
    Set wdDoc = wdApp.Documents.Open(fNameW)
    wdDoc.Activate
    wdDoc.MailMerge.OpenDataSource Name:=(fNameE), Revert:=False, Connection:="Entire Spreadsheet", SQLStatement:="SELECT * FROM `'Table of Recommendations$'`", SQLStatement1:=""
    With wdDoc.MailMerge
        .MainDocumentType = wdCatalog
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute
        
        For Each wd In ActiveDocument.StoryRanges
        With wd.Find
            .Text = "(blank)"
            .Replacement.Text = ""
            .Forward = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
        Next wd
        
        For Each oPara In ActiveDocument.Paragraphs
            With oPara.Range
                If .Information(wdWithInTable) = True Then
                     With .Next
                        If .Information(wdWithInTable) = False Then
                            If .Text = vbCr Then .Delete
                        End If
                    End With
                End If
            End With
        Next
        
        ChangeFileOpenDirectory fod
        ActiveDocument.SaveAs2 Filename:=fnameMB, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
        ActiveDocument.Close
    
    End With
    
    Sheets("Table of Recommendations").Select
    Range(rangeTC).Select
    Selection.Clear
    
    wdDoc.Close savechanges:=wdDoNotSaveChanges