邮件合并来自 Excel 数据的字

Question

I tried to MailMerge Word File using VBA codes(in Excel). When I run the Macro(Code that I wrote), Opening the word file works fine. However in selecting table in Word for mailmerge, there's no table in selecting option. Obviously, I typed refData(Excel file) as

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

But in Word file, it is recognized as "W:\30 Offer\03 MECHANICAL.xls" --> and there's no table.

so, I can't click the 'OK button '. so, I clicked cancel, the the debug pop-up appears with run time error 4198.

Mail Merge part is located at the bottom of codes. I tried hard to fine the reason, but I'm new in VBA, so it's quiet hard to find and fix it. So, I need some helps. If you have time to read my codes, please help me. Thank you.

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

If your Word document has been saved as a mailmerge main document, your code will stall waiting for you to answer the mailmerge SQL prompt. To overcome that you need to employ:

Wrd.DisplayAlerts = wdAlertsNone

before:

Wrd.Documents.Open Filename:=wrdPath

Your SQL statement is also malformed.

For more, see Run a Mailmerge from Excel, Sending the Output to Individual Files in: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html