MailMerge Word from Excel data - 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