Converting Word>Excel mail merge to an Excel>Word merge - excel

Question

Good morning,
I have an Excel document that is set up to complete a mail merge. Previously, a ran a script from within the MS Word mail merge template to call the Excel file, connect to it, and pull in the data. I recently found a code example that suggested embedding the code within the Excel document and pointing it to the Word template. This seems to make a lot more sense given my workflow.
This snippet worked within MS Word to reach out and connect to the Excel workbook:
ThisDocument.MailMerge.OpenDataSource Name:= _
ThisDocument.Path & "\" & "REF 1.23.18.xlsm", 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=reflist.xlsm;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locking " _
, SQLStatement:="SELECT * FROM `REF_LTR$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
However, when I move the script over into MS Excel to try and connect to the Word template from Excel, this script is failing with a "run time error 4198 - Command Failed":
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
ConfirmConversions:=False, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `REF_LTR$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
Any suggestions on what my second block of code is missing?
Here is the entire script for reference:
Sub test()
' Delete the first 8 rows which contain the header data
On Error Resume Next
Rows("1:8").Select
Selection.Delete Shift:=xlUp
' Delete the empty spaces in column A, Name
Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Delete the empty spaces in column B, MRN
Columns("B:B").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Delete the empty spaces in columns D and E, format them as dates
Columns("D:E").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.NumberFormat = "m/d/yyyy"
' Delete the empty spaces in columns F and G
Columns("F:G").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Format AdmitTime as military time
Columns("F:F").Select
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm;#"
Selection.NumberFormat = "hhmm"
' Delete any rows that don't have a name in column A
Columns("A").SpecialCells(xlBlanks).EntireRow.Delete
' Add the column titles
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("1:1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
Range("A1").Select
ActiveCell.FormulaR1C1 = "Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "MRN"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Sex"
Range("D1").Select
ActiveCell.FormulaR1C1 = "DOB"
Range("E1").Select
ActiveCell.FormulaR1C1 = "AdmitDate"
Range("F1").Select
ActiveCell.FormulaR1C1 = "AdmitTime"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Category"
Range("H1").Select
ActiveCell.FormulaR1C1 = "ReferHospital"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Complaint"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Unit"
Range("L1").Select
ActiveCell.FormulaR1C1 = "Disposition"
Range("M1").Select
ActiveCell.FormulaR1C1 = "LOS"
Range("N1").Select
ActiveCell.FormulaR1C1 = "ICD10"
Range("O1").Select
ActiveCell.FormulaR1C1 = "AdmitYear"
Range("P1").Select
ActiveCell.FormulaR1C1 = "AdmitMonth"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "AdmitDay"
Range("R1").Select
ActiveCell.FormulaR1C1 = "GenderPronoun"
Range("A2").Select
' Add the helper columns to pull in the admityear, admitmonth, admitday, and genderpronoun
Range("O2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-14]="""","""",TEXT(RC[-10],""yyyy""))"
Range("O2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-14]="""","""",TEXT(RC[-10],""yyyy""))"
Range("P2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-15]="""","""",TEXT(RC[-11],""mm""))"
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-16]="""","""",TEXT(RC[-12],""dd""))"
Range("R2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-17]="""","""",IF(RC[-15]=""M"",""his"",""her""))"
Range("O2:R2").Select
Selection.Copy
Range("O3:R50").Select
ActiveSheet.Paste
' Find and replace hospital names
Columns("H:H").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Fort Hamilton Hospital
Columns("H:H").Select
Cells.Replace What:="FortHamilton-HughesMemorialHospital(", Replacement _
:="Fort Hamilton Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Grandview
Columns("H:H").Select
Cells.Replace What:="GrandviewHospital(OHMontgomery)", Replacement _
:="Grandview Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Greene Memorial Hospital
Columns("H:H").Select
Cells.Replace What:="GreeneMemorialHospital(OHGreene)", Replacement _
:="Greene Memorial Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Kettering Health Network - Franklin
Columns("H:H").Select
Cells.Replace What:="FRANKLINSPRINGBOROED", Replacement _
:="Kettering Health Network - Franklin", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Kettering Health Network - Huber
Columns("H:H").Select
Cells.Replace What:="HuberHeightsED", Replacement _
:="Kettering Health Network - Huber", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Kettering Health Netowrk - Preble
Columns("H:H").Select
Cells.Replace What:="PrebleCoED", Replacement _
:="Kettering Health Network - Preble", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' McCullough-Hyde Memorial Hospital
Columns("H:H").Select
Cells.Replace What:="McCullough-HydeMemorialHospital(OH", Replacement _
:="McCullough-Hyde Memorial Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Mercer County Community Hospital
Columns("H:H").Select
Cells.Replace What:="MercerCountyJointTwp.CommunityHospi", Replacement _
:="Mercer County Community Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Soin Medical Center
Columns("H:H").Select
Cells.Replace What:="SoinMedicalCenter", Replacement _
:="Soin Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Southview Medical Center
Columns("H:H").Select
Cells.Replace What:="SouthviewHospital&FamilyHealthCente", Replacement _
:="Southview Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Springfield Regional Medical Center
Columns("H:H").Select
Cells.Replace What:="CommunityHospitalofSpringfield(OHCl", Replacement _
:="Springfield Regional Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Columns("H:H").Select
Cells.Replace What:="SpringfieldRegionalHosptial", Replacement _
:="Springfield Regional Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Sycamore Medical Center
Columns("H:H").Select
Cells.Replace What:="SycamoreHospital(OHMontgomery)", Replacement _
:="Sycamore Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Upper Valley Medical Center
Columns("H:H").Select
Cells.Replace What:="UpperValleyMedicalCenter", Replacement _
:="Upper Valley Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Wilson Memorial Hospital
Columns("H:H").Select
Cells.Replace What:="WilsonHospital(OHShelby)", Replacement _
:="Wilson Memorial Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Select A1 cell
Range("A1").Select
' This macro does the following:
' Runs a mail merge and pulls fields to create follow-up letter drafts
' Creates individual Word documents and then saves them in the appropriate folder for the hospital name
'
Dim Name As String
Dim MRN As String
Dim Sex As String
Dim DOB As String
Dim AdmitDate As String
Dim AdmitTime As String
Dim Category As String
Dim ReferHospital As String
Dim Complaint As String
Dim Description As String
Dim Unit As String
Dim Disposition As String
Dim LOS As String
Dim ICD10 As String
Dim AdmitYear As String
Dim AdmitMonth As String
Dim AdmitDay As String
Dim GenderPronoun As String
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
'Check to see if the folder exists, and if not, create it
Dim fdObj As Object
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(ThisDocument.Path & ReferHospital) Then
Else
fdObj.CreateFolder (ThisDocument.Path & ReferHospital)
End If
' NEW!!!!
' Connect to the sign-in spreadsheet which is the data source
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdocSource = wd.Documents.Open("C:\Users\k113997\Desktop\1macrotest\Trauma Referral Template.docm")
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.CreateDataSource _
Name:=strWorkbookName, _
SQLStatement:="SELECT * FROM `REF_LTR$`", _
SubType:=wdMergeSubTypeAccess
' Obtaines the number of records from the mail merge
For i = 1 To ThisDocument.MailMerge.DataSource.RecordCount
' Counts the lines in the excel file
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
' Ignore any records where Name is blank, as in empty data fields
If Trim(.DataFields("Name")) = "" Then Exit For
' Pull in the datafields from the sign-in spreadsheet
Name = .DataFields("Name").Value
MRN = .DataFields("MRN").Value
Sex = .DataFields("Sex").Value
DOB = .DataFields("DOB").Value
AdmitDate = .DataFields("AdmitDate").Value
AdmitTime = .DataFields("AdmitTime").Value
Category = .DataFields("Category").Value
ReferHospital = .DataFields("ReferHospital").Value
Complaint = .DataFields("Complaint").Value
Description = .DataFields("Description").Value
Unit = .DataFields("Unit").Value
Disposition = .DataFields("Disposition").Value
LOS = .DataFields("LOS").Value
ICD10 = .DataFields("ICD10").Value
AdmitYear = .DataFields("AdmitYear").Value
AdmitMonth = .DataFields("AdmitMonth").Value
AdmitDay = .DataFields("AdmitDay").Value
GenderPronoun = .DataFields("GenderPronoun").Value
End With
' Execute the mail merge
.Execute Pause:=False
End With
' Set the directory path for the output files to be the same as the directory for this document
docpath = ThisDocument.Path & "\" & ReferHospital
' Set the document naming convention with the course year, course month, course day, department, and course name
docname = AdmitYear + "-" + AdmitMonth + "-" + AdmitDay + " " + MRN
' Check and make sure that docname does not have any special characters that will mess up the filename, and if found, remove them
docnameclean = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(docname, "<", ""), ">", ""), ":", ""), "/", ""), "\", ""), "?", ""), "&", ""), "*", ""), ",", ""), ".", "")
' Change the focus to the active directory where the files are stored
ChDrive ActiveDocument.Path
' ChangeFileOpenDirectory _
' ".\"
ActiveDocument.SaveAs2 Filename:=docpath & "\" & docnameclean + ".docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
' Close the active document
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
' Switch to the next document in the mail merge
Next i
wd.Visible = True
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
End Sub
Thanks,
Chris

Answer 1

When you open a Word document or attach a Template through VBA, the mail merge data source (if any) is not attached to the document for security reasons.
Try replacing:
wdocSource.MailMerge.OpenDataSource(...)
To:
wdocSource.MailMerge.CreateDataSource(...)
using the same method parameters but do not set the Connection parameter as it will be created for you.
wdocSource.MailMerge.CreateDataSource _
Name:=strWorkbookName, _
SQLStatement:="SELECT * FROM `REF_LTR$`", _
SubType:= wdMergeSubTypeAccess