Mail Merge using VBA in Excel

[chipsworld]

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
Err.Clear
Set objWord = CreateObject("Word.Application")
bCreatedWordInstance = True
End If
If objWord Is Nothing Then
MsgBox "Could not start Word"
Err.Clear
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)
objMMMD.Activate
'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
objWord.Quit
End If
For s = 1 To lastrow
Cells(s, 11).Value = "DONE"
nextrow:
Next s
Next
End Sub

 

[Macropod]

For some alternative mailmerge code see Run a Mailmerge from Excel, Sending the Output to Individual Files in the Mailmerge Tips & Tricks thread at: http://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code has lost whatever structure it had.

 

[chipsworld]

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]Err.Clear[/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]Err.Clear[/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]objMMMD.Activate[/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]objWord.Quit[/COLOR]
[COLOR=#574123]End If[/COLOR]
[COLOR=#574123]For s = 1 To lastrow[/COLOR]
[COLOR=#574123]Cells(s, 11).Value = "DONE"[/COLOR]
[COLOR=#574123]nextrow:[/COLOR]
[COLOR=#574123]Next s[/COLOR]
[COLOR=#574123]Next[/COLOR]
[COLOR=#574123]End Sub
[/COLOR]

 

[Macropod]

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.

 

[chipsworld]

OK...it 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!!!