Automating Word Mail Merge with Excel 2010 VBA

[larryjfoster]

I have an excel workbook where the first sheet is a summary of all accounts and each sheet after is a summary per account. I'd like to automate a mail merge with existing templates already established for the merge. The code below successfully opens the appropriate Word template(s) but says that Word could not open the data source. I suspect the error lies in the (SQLStatement:="SELECT * FROM `'` & account & `$'`",) portion of the code but I'm not sure how to correct it.

Code:

Sub mbrMailMerge()
Dim Sheet As Worksheet, wsName$, N&
Dim dataSrc As String
Dim hDir As String                      'main folder housing all templates
Dim account As String

dataSrc = ActiveWorkbook.FullName
hDir = "C:\folder\subFolder01"

'Open the mail merge letter template
Dim wdDoc As Object
For N = 2 To Sheets.Count
    Sheets(N).Activate
    wsName = ActiveSheet.Name
    account = ActiveSheet.Name
        If wsName = "account01" Then
            Set wdDoc = GetObject(hDir & "subFolder02\subFolder03\account01.docx", "Word.document")
            wdDoc.Application.Visible = True
        ElseIf wsName = "account02" Then
            Set wdDoc = GetObject(hDir & "subFolder02\subFolder03\account02docx", "Word.document")
            wdDoc.Application.Visible = True
        'ElseIf wsName = "account03 Then
            'Set wdDoc = GetObject(hDir & "subFolder02\subFolder03\account03docx", "Word.document")
            'wdDoc.Application.Visible = True
        Else
            MsgBox "Could not find " & wsName & " Member Word Doc for Mail Merge. Please complete manually"
            'Go to next iteration of N in For loop
        End If
        
    ' select datasource and complete mail merge
    With wdDoc.MailMerge
        .OpenDataSource Name:=dataSrc, _
            ConfirmConversions:=False, _
            ReadOnly:=False, _
            LinkToSource:=True, _
            AddToRecentFiles:=False, _
            PasswordDocument:="", _
            PasswordTemplate:="", _
            WritePasswordDocument:="", _
            WritePasswordTemplate:="", _
            Revert:=False, _
            Format:=wdOpenFormatAuto, _
            Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=dataSrc;Mode=Read;Extended Properties=""HDR=YES;IME", _
            SQLStatement:="SELECT * FROM `'` & account & `$'`", _
            SQLStatement1:="", SubType:=wdMergeSubTypeAccess
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
        .Destination = wdSendToNewDocument
        .MainDocumentType = wdNotAMergeDocument
    End With
    
    ' show and save output file
    ' cleanup
    wdDoc.Close SaveChanges:=False
Next
Set wdDoc = Nothing
End Sub

*I'm building this code as I go and resolving issues along the way so you may see other inconsistencies that I have yet to consider but I can't get passed this issue so any help will be much appreciated.

 

[Macropod]

Try:
"SELECT * FROM `" & account & "$`"

 

[larryjfoster]

Thank you for the quick response Paul! This indeed resolved that issue; However, Word is crashing when connecting to the data source if the data source is open. If I close the data source it works fine but this would not be a good workaround for my purposes. Do you have any suggestions or direction you could point me to? Thanks again!

 

[Macropod]

If you're running a mailmerge from Excel and you're trying to open a Word mailmerge main document, the code will stall while it waits for you to answer the mailmerge SQL prompt. To prevent that, you need to suppress the prompt.

Try:

Sub mbrMailMerge()
Dim Sheet As Worksheet, wsName As String, N As Long, dataSrc As String
Dim wdApp As New Word.Application, wdDoc As Word.Document
dataSrc = ActiveWorkbook.FullName
Const hDir As String = "C:\folder\subFolder01"
wdApp.DisplayAlerts = wdAlertsNone

For N = 2 To Sheets.Count
  wsName = Sheets(N).Name
  Select Case wsName
    Case "account01", "account02" ',"account03"
      Set wdDoc = wdApp.Documents.Open(hDir & "subFolder02\subFolder03\" & wsName & ".docx", AddToRecentFiles:=False)
      Call Mailmerge(wdDoc, dataSrc, wsName)
    Case Else
    MsgBox "Could not find " & wsName & " Member Word Doc for Mail Merge. Please complete manually.", vbExclamation
  End Select
Next
wdApp.DisplayAlerts = wdAlertsAll
wdApp.Visible = True
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

Sub Mailmerge(wdDoc As Word.Document, dataSrc As String, wsName As String)
With wdDoc
  ' select datasource and complete mail merge
  With .Mailmerge
    .MainDocumentType = wdFormLetters
    .OpenDataSource Name:=dataSrc, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
    AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
    WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
    Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=dataSrc;Mode=Read;" & _
    "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & wsName & "$`", SQLStatement1:=""
    With .DataSource
      .FirstRecord = wdDefaultFirstRecord
      .LastRecord = wdDefaultLastRecord
    End With
    .Execute Pause:=False
    .Destination = wdSendToNewDocument
  End With
  .Close SaveChanges:=False
End With
End Sub

 

[larryjfoster]

Thank you Paul! I've been able to successfully complete this project! The sample I provided was greatly simplified for purposes of getting that one issue solved so your thorough and thoughtful example didn't really apply. However, some aspects of it will likely be useful in future projects. Thanks again!