Mail Merge using VBA in Excel


Board Regular
May 23, 2019
I am trying to simplify a process here at work, but have run into a problem that I can not identify. I run the below, and it will only output one line entry from the spreadsheet. i.e. If I have 10 lines on the sheet, I only get the first one. All tough each line is marked as "DONE" in column 11.
I know this should be obvious, but I am having no luck at all identifying where the breakdown is.

If someone could take a look, I would be very grateful.

Dim bCreatedWordInstance As Boolean
Dim objWord As Object
Dim objMMMD As Object
Dim SMName As String
Dim cDir As String
Dim r As Long
Dim s As Long
Dim ThisFileName As String

lastrow = Sheets("Data").Range("B" & Rows.Count).End(xlUp).Row
r = 1
For r = 1 To lastrow
If Cells(r, 11).Value = "DONE" Then GoTo nextrow

SMName = Sheets("Data").Cells(r, 2).Value
' Setup filenames
Const WTempName = "ARReleaseMerge.docx" 'This is the Word Templates name, Change as req'd
Dim NewFileName As String

' Setup directories
cDir = ActiveWorkbook.Path + "" 'Change if appropriate
ThisFileName = ThisWorkbook.Name
On Error Resume Next
' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
bCreatedWordInstance = True
End If
If objWord Is Nothing Then
MsgBox "Could not start Word"
On Error GoTo 0
Exit Sub
End If

' Let Word trap the errors
On Error GoTo 0
' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False
'Open Word Template
Set objMMMD = objWord.Documents.Open(cDir + WTempName)
'Merge the data
With objMMMD
.MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Data$`" ' Set this as required
With objMMMD.MailMerge 'With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1

End With
.Execute Pause:=False
End With
End With
' Save new file
NewFileName = SMName & " - Release Letter " & ".docx" 'This is the New Word Documents File Name, Change as req'd"
objWord.ActiveDocument.SaveAs cDir + NewFileName
' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing
' Close the New Mail Merged Document
If bCreatedWordInstance Then
End If
For s = 1 To lastrow
Cells(s, 11).Value = "DONE"
Next s
End Sub

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.


Board Regular
May 23, 2019
Thank you for the link, but I have perused it several times already, and still don't have an answer to my issue.

As to the # thing for code, sorry...was unaware, I will try it again and see what happens. I just can't figure out why it only outputs the first doc and not all. THe code does update all lines in the spreadsheet, so I know it is running through the loop. I have traced it many times, and just can't figure out where it is going awry. THE only thing I can think of has to do with the network path. With a network stored account, I believe it might be losing connection with the network path to the folder. Since this folder is local, but still runs through the network security device, it is hard to tell.
If you can't see any code reason why it is failing, I will have to start looking at the network thing and see how I can run and end round.
Any help would be appreciated.

[COLOR=#574123]Dim bCreatedWordInstance As Boolean[/COLOR]
[COLOR=#574123]Dim objWord As Object[/COLOR]
[COLOR=#574123]Dim objMMMD As Object[/COLOR]
[COLOR=#574123]Dim SMName As String[/COLOR]
[COLOR=#574123]Dim cDir As String[/COLOR]
[COLOR=#574123]Dim r As Long[/COLOR]
[COLOR=#574123]Dim s As Long[/COLOR]
[COLOR=#574123]Dim ThisFileName As String[/COLOR]

[COLOR=#574123]lastrow = Sheets("Data").Range("B" & Rows.Count).End(xlUp).Row[/COLOR]
[COLOR=#574123]r = 1[/COLOR]
[COLOR=#574123]For r = 1 To lastrow[/COLOR]
[COLOR=#574123]If Cells(r, 11).Value = "DONE" Then GoTo nextrow[/COLOR]

[COLOR=#574123]SMName = Sheets("Data").Cells(r, 2).Value[/COLOR]
[COLOR=#574123]' Setup filenames[/COLOR]
[COLOR=#574123]Const WTempName = "ARReleaseMerge.docx" 'Word Template name[/COLOR]
[COLOR=#574123]Dim NewFileName As String[/COLOR]

[COLOR=#574123]' Setup directories[/COLOR]
[COLOR=#574123]cDir = ActiveWorkbook.Path + "" [/COLOR]
[COLOR=#574123]ThisFileName = ThisWorkbook.Name[/COLOR]
[COLOR=#574123]On Error Resume Next[/COLOR]
[COLOR=#574123]' Create a Word Application instance[/COLOR]
[COLOR=#574123]bCreatedWordInstance = False[/COLOR]
[COLOR=#574123]Set objWord = GetObject(, "Word.Application")[/COLOR]
[COLOR=#574123]If objWord Is Nothing Then[/COLOR]
[COLOR=#574123]Set objWord = CreateObject("Word.Application")[/COLOR]
[COLOR=#574123]bCreatedWordInstance = True[/COLOR]
[COLOR=#574123]End If[/COLOR]
[COLOR=#574123]If objWord Is Nothing Then[/COLOR]
[COLOR=#574123]MsgBox "Could not start Word"[/COLOR]
[COLOR=#574123]On Error GoTo 0[/COLOR]
[COLOR=#574123]Exit Sub[/COLOR]
[COLOR=#574123]End If[/COLOR]

[COLOR=#574123]' Let Word trap the errors[/COLOR]
[COLOR=#574123]On Error GoTo 0[/COLOR]

[COLOR=#574123]objWord.Visible = False[/COLOR]
[COLOR=#574123]'Open Word Template[/COLOR]
[COLOR=#574123]Set objMMMD = objWord.Documents.Open(cDir + WTempName)[/COLOR]
[COLOR=#574123]'Merge the data[/COLOR]
[COLOR=#574123]With objMMMD[/COLOR]
[COLOR=#574123].MailMerge.OpenDataSource Name:=cDir + ThisFileName, sqlstatement:="SELECT * FROM `Data$`" [/COLOR]
[COLOR=#574123]With objMMMD.MailMerge 'With ActiveDocument.MailMerge[/COLOR]
[COLOR=#574123].Destination = wdSendToNewDocument[/COLOR]
[COLOR=#574123].SuppressBlankLines = True[/COLOR]
[COLOR=#574123]With .DataSource[/COLOR]
[COLOR=#574123].FirstRecord = r - 1[/COLOR]
[COLOR=#574123].LastRecord = r - 1[/COLOR]
[COLOR=#574123].ActiveRecord = r - 1[/COLOR]

[COLOR=#574123]End With[/COLOR]
[COLOR=#574123].Execute Pause:=False[/COLOR]
[COLOR=#574123]End With[/COLOR]
[COLOR=#574123]End With[/COLOR]
[COLOR=#574123]' Save new file[/COLOR]
[COLOR=#574123]NewFileName = SMName & " - Release Letter " & ".docx" 'This is the New Word Documents File Name[/COLOR]
[COLOR=#574123]objWord.ActiveDocument.SaveAs cDir + NewFileName[/COLOR]
[COLOR=#574123]' Close the Mail Merge Main Document[/COLOR]
[COLOR=#574123]objMMMD.Close savechanges:=wdDoNotSaveChanges[/COLOR]
[COLOR=#574123]Set objMMMD = Nothing[/COLOR]
[COLOR=#574123]' Close the New Mail Merged Document[/COLOR]
[COLOR=#574123]If bCreatedWordInstance Then[/COLOR]
[COLOR=#574123]End If[/COLOR]
[COLOR=#574123]For s = 1 To lastrow[/COLOR]
[COLOR=#574123]Cells(s, 11).Value = "DONE"[/COLOR]
[COLOR=#574123]Next s[/COLOR]
[COLOR=#574123]End Sub


Retired Moderator
Aug 27, 2007
You really should look more closely at the code in the link; it would only require a few changes to merge all your records and to exclude records that already have the 'DONE' parameter set. Your own code - which still lacks a proper structure - potentially repeatedly creates new Word instances, then destroys them, which is a huge drain on performance.


Board Regular
May 23, 2019
90 took me a while, but using the we age you suggested, I did finally figure it out.
May no be prettiest code ever, but it works and that is what matters!

Thank you very much!!!

Watch MrExcel Video

Forum statistics

Latest member

This Week's Hot Topics