来自MailMerge数据的Excel Word

Question

我尝试使用VBA码(在MailMerge中)来打开Word文件。当我运行Macro(我编写的代码)时，打开word文件工作正常。但是，在Word中选择表格进行邮件合并时，在选择选项中没有表格。显然，我键入的refData(Excel文件)是

refData = "W:\30 Offer\03 MECHANICAL\*Project_Offer_Number_for MECH_210302_ver2.xlsm*"

但在Word文件中，它被识别为"W:\30 Offer\03 MECHANICAL.xls“-->并且没有表格。

所以，我不能点击“确定”按钮。因此，我单击了cancel，出现调试弹出窗口并显示运行时错误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 Offer\03 MECHANICAL"
    ComDir = "W:\30 Offer\03 MECHANICAL\" & CoName
    PjtDir = "W:\30 Offer\03 MECHANICAL\" & CoName & "\" & OffrNm & " " & EndCusName & " " & Pjt
    TempDir = MainDir & "\_New Rule_Customer location\Offer 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 Offer\03 MECHANICAL\_New Rule_Customer location\Offer No_project name"
                strToFolder = PjtDir
                FSO.CopyFolder _
                Source:=strFromFolder, Destination:=strToFolder, overwritefiles:=True
        Else
            MkDir PjtDir
            
             Set FSO = CreateObject("scripting.filesystemobject")
                strFromFolder = "W:\30 Offer\03 MECHANICAL\_New Rule_Customer location\Offer 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 Offer\03 MECHANICAL\_New Rule_Customer location\Offer 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 & "\01_COSTS\13_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 & "\01_COSTS\13_COST_BASIS\Offer calc_offerNr_pjt name_date.xlsx"
    newName = PjtDir & "\01_COSTS\13_COST_BASIS\Offer 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 Offer\03 MECHANICAL\_New Rule_Customer location\Offer No_project name\02_OFFER\Offer_OfferNr_pjt name_date.doc"
refData = "W:\30 Offer\03 MECHANICAL\Project_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 & "\02_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