早上好，
我有一个Excel文档，用于完成邮件合并。以前，从MS Word邮件合并模板中运行一个脚本来调用Excel文件，连接到它并拉入数据。我最近发现了一个代码示例，建议在Excel文档中嵌入代码并将其指向Word模板。考虑到我的工作流程，这似乎更有意义。
此代码段在MS Word中工作，可以伸出并连接到Excel工作簿：
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
但是，当我将脚本移到MS Excel中以尝试从Excel连接到Word模板时，此脚本失败并显示＆＃34;运行时错误4198 - 命令失败＆＃34;：
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
有关我的第二个代码块丢失的建议吗？
以下是整个脚本供参考：
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
谢谢， 克里斯
答案 0 :(得分：0)
当您通过VBA打开Word文档或附加模板时，出于安全原因，邮件合并数据源（如果有）未附加到文档。
尝试更换：
wdocSource.MailMerge.OpenDataSource(...)
要：
wdocSource.MailMerge.CreateDataSource(...)
使用相同的方法参数，但不要设置Connection参数，因为它将为您创建。
wdocSource.MailMerge.CreateDataSource _
Name:=strWorkbookName, _
SQLStatement:="SELECT * FROM `REF_LTR$`", _
SubType:= wdMergeSubTypeAccess