从Excel数据中合并Word

Question

我尝试使用VBA代码(在Excel中)邮寄合并Word文件。当我运行宏(我写的代码)时，打开word文件工作正常。然而，在Word的邮件合并选择表中，没有选择表选项。显然，我输入refData(Excel文件)为

refData = "W:30 Offer3 MECHANICAL*Project_Offer_Number_for MECH_210302_ver2.xlsm*"

但在Word文件中，它被识别为"W:30 Offer3 MECHANICAL.xls"——比;也没有桌子。

所以，我不能点击"OK按钮"。所以，我点击取消，调试弹出窗口出现运行时错误4198。

邮件合并部分位于代码的底部。我努力寻找原因，但我是VBA新手，所以很难找到和修复它。所以，我需要一些帮助。如果你有时间读我的代码，请帮助我。谢谢你。

Private Function folder_exister(flderName As String) As Boolean 'Existing Folder Tester
If Len(Dir(flderName, vbDirectory)) <> 0 Then
folder_exister = True
Else
folder_exister = False
End If
End Function
Sub Gen_Offer_folder()
'Common Declaration-------------------------------------------------------------------
Dim r As Integer 'Codes for Latest Row
Sheets("Offer").Select
Cells(14, 2).Select
Selection.End(xlDown).Select
r = Selection.Row

Dim CoName As String, EndCusName As String
Dim OffrNm As String, Pjt As String
Dim ResPer As String
CoName = Cells(r, 4).Value
EndCusName = Cells(r, 5).Value
OffrNm = Cells(r, 2).Value
ResPer = Cells(r, 6).Value
Pjt = Cells(r, 3).Value
Dim MainDir As String
Dim ComDir As String
Dim PjtDir As String
Dim TempDir As String
MainDir = "W:30 Offer3 MECHANICAL"
ComDir = "W:30 Offer3 MECHANICAL" & CoName
PjtDir = "W:30 Offer3 MECHANICAL" & CoName & "" & OffrNm & " " & EndCusName & " " & Pjt
TempDir = MainDir & "_New Rule_Customer locationOffer No_project name"

'Create Folders & Files---------------------------------------------------------
Dim FSO As Object
Dim strFromFolder As String
Dim strToFolder As String
If folder_exister(ComDir) Then 'create sub-folders in existing folder
If folder_exister(PjtDir) Then
Set FSO = CreateObject("scripting.filesystemobject")
strFromFolder = "W:30 Offer3 MECHANICAL_New Rule_Customer locationOffer No_project name"
strToFolder = PjtDir
FSO.CopyFolder _
Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
Else
MkDir PjtDir

Set FSO = CreateObject("scripting.filesystemobject")
strFromFolder = "W:30 Offer3 MECHANICAL_New Rule_Customer locationOffer No_project name"
strToFolder = PjtDir
FSO.CopyFolder _
Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
End If

Else 'create sub-folders in generated folder
MkDir ComDir
MkDir PjtDir

Set FSO = CreateObject("scripting.filesystemobject")
strFromFolder = "W:30 Offer3 MECHANICAL_New Rule_Customer locationOffer No_project name"
strToFolder = PjtDir
FSO.CopyFolder _
Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
End If
Set FSO = Nothing

'Fill the calc sheet-------------------------------------------------------------
Dim a As String, b As String, c As String, d As String, e As String, f As String, g As String, h As String
a = ThisWorkbook.Sheets("Offer").Cells(r, 2).Value  'Offer Number
b = ThisWorkbook.Sheets("Offer").Cells(r, 3).Value  'Pjt Name
c = ThisWorkbook.Sheets("Offer").Cells(r, 4).Value  'Customer Name
d = ThisWorkbook.Sheets("Offer").Cells(r, 5).Value  'End Customer Name
e = ThisWorkbook.Sheets("Offer").Cells(r, 6).Value  'Resp. Person
Dim wkb As Workbook
Application.ScreenUpdating = False
Set wkb = Workbooks.Open(PjtDir & "1_COSTS13_COST_BASIS" & "Offer calc_offerNr_pjt name_date.xlsx")

With wkb

With .Worksheets("Calc sheet")

.Range("A3").Value = Date    'Date
.Range("J14").Value = Date   'Date
.Range("G12").Value = Date   'Date
.Range("B3").Value = e       'Resp. Name
.Range("J13").Value = e      'Resp. Name
.Range("G13").Value = Today  'Updated Day <-- Today

.Range("B10").Value = c
.Range("B11").Value = d
.Range("B12").Value = b

.Range("G10").Value = a

End With

.Close SaveChanges:=True      'save changes then close

End With
Set wkb = Nothing

'change offer calc name------------------------------------------------------------
Dim oldName As String, newName As String
oldName = PjtDir & "1_COSTS13_COST_BASISOffer calc_offerNr_pjt name_date.xlsx"
newName = PjtDir & "1_COSTS13_COST_BASISOffer calc_" & OffrNm & "_" & EndCusName & "_" & Pjt & "_" & Date & ".xlsx"


On Error GoTo Here 'If the File is aready exist, then These Codes DO NOT Create New One or Overwite.
Name oldName As newName
Exit Sub
Here:
MsgBox "Already Existing Calc Sheet File"




'Mail Merge(Word File)///////////////////////////////////////////////////////////////
'Create Offer doc sheet at Calc Sheet for MailMerge
With ThisWorkbook
.Sheets("for_MailMerge").Range("a2").Value = Pjt
.Sheets("for_MailMerge").Range("b2").Value = OffrNm
.Sheets("for_MailMerge").Range("c2").Value = CoName
.Sheets("for_MailMerge").Range("d2").Value = EndCusName
.Sheets("for_MailMerge").Range("e2").Value = Date
.Sheets("for_MailMerge").Range("f2").Value = ResPer
End With

'Create Word File Object
Dim Wrd As Object
Set Wrd = CreateObject("word.application")
Wrd.Visible = True

Dim wrdPath As String, refData As String, xlConnectionString As String
wrdPath = "W:30 Offer3 MECHANICAL_New Rule_Customer locationOffer No_project name2_OFFEROffer_OfferNr_pjt name_date.doc"
refData = "W:30 Offer3 MECHANICALProject_Offer_Number_for MECH_210302_ver2.xlsm"

'Open THE Word File
Wrd.Documents.Open Filename:=wrdPath
'Write on Word
Wrd.ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
'Define Connection String
xlConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "User ID=Admin;" _
& "Data Source=" + refData + ";" _
& "Mode=Read;" _
& "Extended Porperties=""" _
& "HDR=YES;" _
& "IMEX=;"";" _
& "Jet OLEDB:System database="""";" _
& "Jet OLEDB:Regist"
'Open a Connection to the Excel 'For word template file
With Wrd.ActiveDocument.MailMerge
.OpenDataSource _
Name:=refData, _
LinkToSource:=True, _
Connection:=xlConnectionString, _
SQLStatement:="SELECT * FROM 'for_MailMerge$`"
'Simulate running the mail merge and return any errors
.Check

'We can see either the Values(False) or the Fields Name(True)
.ViewMailMergeFieldCodes = False

'Specify the destination
.Destination = wdSendToNewDocumunent

'Execute the mail merger, and don't pause for errors
.Execute Pause:=False
End With
'for Created word file
Wrd.ActiveDocument.SaveAs Filename:=PjtDir & "2_OFFER" & "Offer_" & OffrNm & "_" & Pjt & "_" & Date & ".doc"
Wrd.ActiveWindow.Close

Wrd.ActiveDocument.Close SaveChanges:=True
Wrd.Quit

Set Wrd = Nothing

MsgBox "Completed"
ActiveWorkbook.Save

End Sub

Answer 1

如果您的Word文档已保存为mailmerge主文档，那么您的代码将停止等待您回答mailmerge SQL提示。为了克服这个问题，你需要使用:

Wrd.DisplayAlerts = wdAlertsNone

:

Wrd.Documents.Open Filename:=wrdPath

你的SQL语句也是错误的。

有关更多信息，请参阅从Excel中运行邮件合并，将输出发送到单个文件中的https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html