Outlook Mail Merge only reading from the first record

It is hard to understand exactly what the code is trying to do. There doesn't seem to be an actual Mail Merge process in it.
It appears to modify the Mail Merge Main document in an idiosyncratic way. It then copies the Main document  to the Outlook message text and sets up the required message fields from a spreadsheet.

I would therefore expect the message text to be the same for all messages with the merge fields looking like this «MyField» instead of the data from the datasource.

Can we ask that you post some non-confidential samples of what you are trying to work with? This would be the spreadsheet with the
CC and subject line data, the word main document and its datasource if it different from the first  spreadsheet.

Hi Graham,

First off, thank you for your response!

I've attached the word document and the spreadsheet for your perusal.

Essentially, I have a PL/SQL to spit out a datasource document to send out alerts for changes of employee working shift when said employee is needed. This is one of many that we will be sending as these emails can amount to 200+ a day and obviously takes a great amount of time for the staff doing this to send out.

Thanks,
OPRR-Worked-for-Merge-EXAMPLE.xls
OPRR-Mail-Merge-EXAMPLE.docx

Thanks.
I have had another look at the code that were trying to use. It seems  to be stepping through  the datasource and editing a mail merge main document instead of running the merge. However, it only edits one field and, if editing is to be done in place of merging, it is easier to use some other way of having a form document rather than the merge document.

I think that it would be better to ditch most of the code and to restructure it so that it does the merge one step at a time, capturing the CC and To fields for each step.

It will take me a while, so I hope you can wait a bit.

Yeah, I'm happy to wait! Your help is much appreciated.

Really the only enhancement to the stock word mail merge is to add a CC field (for multiple recipients) and a custom subject line that also reads from the datasource.

If you know of any easier solutions, ie, ditching the word document and doing the whole thing from the spreadsheet, or whatever, I'm open to ideas!

Thanks again.

Still not quite there. There are problems where it tries to have the same document/workbook open more than once, This is what I have so far,

Sub RunMerge_29041337()
    'Change the spreadsheet columns that the data is in on the next four lines'
    Dim iColAddress As Integer
    Dim iColCC As Integer
    'Dim iColSubject As Integer
    'Dim iColGreeting As Integer
    
    Const wdFormatOriginalFormatting = 16
    
    Dim xlApp As Excel.Application
    Dim xlWbk As Excel.Workbook
    Dim xlWks As Excel.Worksheet
    Dim wdApp As Word.Application
    Dim wdDocMain As Word.Document
    Dim wdDocResult As Word.Document
    Dim wdRng As Word.Range
        'wdFld As Object, _
        'wdSel As Object
    Dim olMsg As Outlook.MailItem
    Dim olIns As Outlook.Inspector
    Dim wrdOlDoc As Word.Document
        'olkSel As Object
    Dim r As Long
    Dim c As Long
    Dim f As Integer
    
    Dim strFolder As String
    strFolder = "I:\Allwork\ee\29041337\"
    
    'Initialize Excel'
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    'Change the file name and path on the next line'
    
    
    'Initialize Word'
    On Error Resume Next
    Set wdApp = GetObject("Word.Application")
    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
    End If
    wdApp.Visible = True
    'Merge'nn
    
    'Dim r As Integer
    'Dim rng As Word.Range
    Dim iLastRecord As Integer
    
    Set wdDocMain = wdApp.Documents.Open(strFolder & "OPRR-Mail-Merge-EXAMPLE.docx")
    With wdDocMain.MailMerge
        .MainDocumentType = wdFormLetters
        .OpenDataSource Name:=xlWbk, SQLStatement:="Select * from `'Sheet1'`"
        Set xlWbk = xlApp.Workbooks.Open(FileName:=strFolder & "OPRR-Worked-for-Merge-EXAMPLE.xls", ReadOnly:=True)
        Set xlWks = xlWbk.Sheets(1)
        c = 1
        Do Until f = 2
            Select Case xlWks.Cells(1, c).Value
                Case "CC"
                    iColCC = c
                    f = f + 1
                Case "TO"
                    iColAddress = c
                    f = f + 1
            End Select
            c = c + 1
        Loop
        
        Set xlWks = xlWbk.Worksheets(1)
        .DataSource.ActiveRecord = wdLastDataSourceRecord
        iLastRecord = .DataSource.ActiveRecord
        .Destination = wdSendToNewDocument
        r = 0
        Do Until r = iLastRecord
            .DataSource.LastRecord = r
            .DataSource.FirstRecord = r
            .Execute
            r = r + 1
            
            Set wdDocResult = wdApp.ActiveDocument
            Set olMsg = Outlook.Application.CreateItem(olMailItem)
            Set olIns = olMsg.GetInspector
            Set wrdOlDoc = olIns.WordEditor
            Set wdRng = wdDocResult.Range
            
            wdRng.Copy
            wrdOlDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
            With olMsg
                .To = xlWks.Cells(r, iColAddress)
                .CC = xlWks.Cells(r, iColCC)
                '.Subject = xlWks.Cells(r, iColSubject)
                .Display
                .Send
                .Close olSave
            End With
            wdDocResult.Close
        Loop
    End With
    
    wdDocMain.Close False

    xlWbk.Close False
    xlApp.Quit
    wdApp.Quit False
End Sub

Select allOpen in new window

Here is a tidied-up version.
Note that it works best if the document to be the Mail Merge Main document is actually set to be a Normal Word Document,  (Start Mail Merge button). Otherwise you will get the security confirmation message when the macro runs. The code sets it up as a Mail Merge document,

I note that the messages sent don't seem to have bounced, so I hope that there aren't any recipients who might be upset.

Sub RunMerge_29041337()
    Dim iColAddress As Integer
    Dim iColCC As Integer
    
    Dim xlApp As Excel.Application
    Dim xlWbk As Excel.Workbook
    Dim xlWks As Excel.Worksheet
    
    Dim wrdApp As Word.Application
    Dim wrdDocMain As Word.Document
    Dim wrdDocResult As Word.Document
    Dim wrdRng As Word.Range
    
    Dim olkMsg As Outlook.MailItem
    Dim olkIns As Outlook.Inspector
    Dim olkDoc As Word.Document
    
    Dim r As Integer 'row/record counter
    Dim c As Integer 'column counter
    Dim f As Integer 'special field counter
    Dim bNewInstance As Boolean
    Dim iLastRecord As Integer
    
    Dim strFolder As String
    Dim strMainDoc As String
    Dim strWorkbook As String
    
    
    strFolder = "I:\Allwork\ee\29041337\"
    strMainDoc = "OPRR-Mail-Merge-EXAMPLE.docx"
    strWorkbook = "OPRR-Worked-for-Merge-EXAMPLE.xls"
    
    'Get Excel application
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    
    'Get Word application, avoiding the creation of multiple instances
    On Error Resume Next
    Set wrdApp = GetObject("Word.Application")
    If wrdApp Is Nothing Then
        Set wrdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    wrdApp.Visible = True
    
    Set xlWbk = xlApp.Workbooks.Open(FileName:=strFolder & strWorkbook, ReadOnly:=True)
    Set xlWks = xlWbk.Sheets(1)
    
    'find columns for CC and TO
    c = 1
    Do Until f = 2
        Select Case xlWks.Cells(1, c).Value
            Case "CC"
                iColCC = c
                f = f + 1
            Case "TO"
                iColAddress = c
                f = f + 1
        End Select
        c = c + 1
    Loop

    'start merge process
    Set wrdDocMain = wrdApp.Documents.Open(strFolder & strMainDoc)
    With wrdDocMain.MailMerge
        .MainDocumentType = wdFormLetters
        .Destination = wdSendToNewDocument
        'connect to spreadsheet
        .OpenDataSource Name:=xlWbk.FullName, ReadOnly:=True, SQLStatement:="Select * from `'Sheet 1$'`"
        
        .DataSource.ActiveRecord = wdLastDataSourceRecord
        iLastRecord = .DataSource.ActiveRecord
        r = 0
        'run merge one record at' a time
        Do Until r = iLastRecord
            .DataSource.LastRecord = r
            .DataSource.FirstRecord = r
            .Execute
            r = r + 1
            Set wrdDocResult = wrdApp.ActiveDocument
            
            Set olkMsg = Outlook.Application.CreateItem(olMailItem)
            Set olkIns = olkMsg.GetInspector
            Set olkDoc = olkIns.WordEditor
        
            'copy text from result document to message
            Set wrdRng = wrdDocResult.Range
            wrdRng.Copy
            olkDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
            
            'send the message
            With olkMsg
                .To = xlWks.Cells(r + 1, iColAddress)
                .CC = xlWks.Cells(r + 1, iColCC)
                '.Display
                .Send
            End With
            'finish with result document for this record
            wrdDocResult.Close wdDoNotSaveChanges
        Loop
    End With
    
    'tidy up
    xlWbk.Close False
    xlApp.Quit
    
    wrdDocMain.Close wdDoNotSaveChanges
    If bNewInstance Then
        wrdApp.Quit False
    End If
End Sub

Select allOpen in new window

Hi Graham,

Thank you so much for all your work with this - currently out the office though but I'll be back in tomorrow and try this right away and report back!

Thanks again!

Hi Graham,

Just tried this out, having a couple of issues: 1st if run as is without a .Display used in olkMsg then the emails sent are completely blank with nothing in the body at all. If, however, I use .Display then the first email generated seems to run off all results in the body (the contents of the muliple emails) while the other generated items look fine.

My other issue, and I see that you did have it in orginally, is the subject is not copied from the datasource. I had a go at this myself using the same methods that you had used to define a iColSubject, select from a case to cycle through and then try to reference it in the olkMsg but I am getting an invalid or empty clipboard error.

Thanks,

OK John,
After I got the send bit working, I didn't actually look at the contents.
I will try out the subject line myself.

Subject and message content now working:

Sub RunMerge_29041337()
    Dim iColAddress As Integer
    Dim iColCC As Integer
    Dim iColSubject As Integer
    
    Dim xlApp As Excel.Application
    Dim xlWbk As Excel.Workbook
    Dim xlWks As Excel.Worksheet
    
    Dim wrdApp As Word.Application
    Dim wrdDocMain As Word.Document
    Dim wrdDocResult As Word.Document
    Dim wrdRng As Word.Range
    
    Dim olkMsg As Outlook.MailItem
    Dim olkIns As Outlook.Inspector
    Dim olkDoc As Word.Document
    
    Dim r As Integer 'row/record counter
    Dim c As Integer 'column counter
    Dim f As Integer 'special field counter
    Dim bNewInstance As Boolean
    Dim iLastRecord As Integer
    
    Dim strFolder As String
    Dim strMainDoc As String
    Dim strWorkbook As String
    
    
    strFolder = "I:\Allwork\ee\29041337\"
    strMainDoc = "OPRR-Mail-Merge-EXAMPLE.docx"
    strWorkbook = "OPRR-Worked-for-Merge-EXAMPLE.xls"
    
    'Get Excel application
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    
    'Get Word application, avoiding the creation of multiple instances
    On Error Resume Next
    Set wrdApp = GetObject("Word.Application")
    If wrdApp Is Nothing Then
        Set wrdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    wrdApp.Visible = True
    
    Set xlWbk = xlApp.Workbooks.Open(FileName:=strFolder & strWorkbook, ReadOnly:=True)
    Set xlWks = xlWbk.Sheets(1)
    
    'find columns for CC and TO
    c = 1
    Do Until f = 3
        Select Case xlWks.Cells(1, c).Value
            Case "CC"
                iColCC = c
                f = f + 1
            Case "TO"
                iColAddress = c
                f = f + 1
            Case "SUBJECT"
                iColSubject = c
                f = f + 1
        End Select
        c = c + 1
    Loop

    'start merge process
    Set wrdDocMain = wrdApp.Documents.Open(strFolder & strMainDoc)
    With wrdDocMain.MailMerge
        .MainDocumentType = wdFormLetters
        .Destination = wdSendToNewDocument
        'connect to spreadsheet
        .OpenDataSource Name:=xlWbk.FullName, ReadOnly:=True, SQLStatement:="Select * from `'Sheet 1$'`"
        
        .DataSource.ActiveRecord = wdLastDataSourceRecord
        iLastRecord = .DataSource.ActiveRecord
        r = 0
        'run merge one record at' a time
        Do Until r = iLastRecord
            .DataSource.LastRecord = r
            .DataSource.FirstRecord = r
            .Execute
            r = r + 1
            Set wrdDocResult = wrdApp.ActiveDocument
            
            Set olkMsg = Outlook.Application.CreateItem(olMailItem)
            Set olkIns = olkMsg.GetInspector
            Set olkDoc = olkIns.WordEditor
        
            'copy text from result document to message
            Set wrdRng = wrdDocResult.Range
            wrdRng.Copy
            olkDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
            
            'send the message
            With olkMsg
                .To = xlWks.Cells(r + 1, iColAddress)
                .CC = xlWks.Cells(r + 1, iColCC)
                .Subject = xlWks.Cells(r + 1, iColSubject)
                .Display
                .Send
            End With
            'finish with result document for this record
            wrdDocResult.Close wdDoNotSaveChanges
        Loop
    End With
    
    'tidy up
    xlWbk.Close False
    xlApp.Quit
    
    wrdDocMain.Close wdDoNotSaveChanges
    If bNewInstance Then
        wrdApp.Quit False
    End If
End Sub

Select allOpen in new window

That worked a treat, thanks.

The only outstanding issue is the joined content on the body of the mail for the first person on the datasource. Looks like there is a page break inserted into that then the content switches to that of the next record.

I've pasted the content out of the mail into a Word doc (I only ran a datasource with 2 entries to cut down on the size of the example)
First-Recipient-Mail-Example.docx

It looks like the result of a  merge of a merge run on the first two records, except they are in reverse order.
Interesting, but I can't reproduce that outcome. Does it happen every time on your system?

Yeah, everytime I've tested it!

Tried it again there, you are right, it is just the first two entries that are merged - I hadn't realised that I had used a longer merge document in one of my tests with more info on it.

I have just had a protesting reply from someone whose name does not appear in spreadsheet. His email address is completely different from any on the sheet. He seems to have received the message for employee no 2.

How would that come about? That's very odd

I've sent you the address via EE EE message,
Do you have a list that always fails?

I got your message and replied back.

No, the only issue is still the double merged initial mail, that's all!

I think I will need to see the list. If it still fails when shortened, can you post the shortest list that does so?

Sorry, was out the office on Friday again.

I've attached the shortened list

Also, I am using Office 2016 products on the chance that makes a difference?
OPRR-Worked-for-Mergetest.xlsx

This is absolutely a godsend and you've done a heck of job helping me out! If I could buy you a beer (or 10) I would!

Thank you so much!