I've streamlined the logic of your code so it is cleaner but I'm not sure it will solve your issue and I don't have a file to do any testing on. Give this a try and if you cross your fingers you might find it works
Code:
Sub test_update(docPath As String, dataSourcePath As String, sqlQuery As String)
Dim wdApp As Object, wdDoc As Object
' Open Word application
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
If wdApp Is Nothing Then ' Check if Word application is open
MsgBox "Unable to open or create Word application.", vbExclamation
Exit Sub
End If
' Open the Word document
On Error Resume Next
wdApp.DisplayAlerts = False
Set wdDoc = wdApp.Documents.Open(docPath, False, True, False, , , , , , , , True) 'set object as Word document used as base
wdApp.DisplayAlerts = True
' Ignore specific merge file errors
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
If wdDoc Is Nothing Then
MsgBox "Unable to open the Word document: " & docPath, vbExclamation
Exit Sub
End If
' Update the data source
On Error GoTo HandleError 'This will send the macro down to HandleError before returning
With wdDoc.MailMerge
.MainDocumentType = 0 ' wdFormLetters
.OpenDataSource Name:=dataSourcePath, _
ConfirmConversions:=False, ReadOnly:=True, _
LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", _
Revert:=False, Format:=0, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dataSourcePath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=sqlQuery
End With
' Save and Close the document
wdDoc.Close SaveChanges:=True
' Quit Word application if no other documents are open
If wdApp.Documents.Count = 0 Then wdApp.Quit SaveChanges:=False
' Release objects
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "Mail merge data source updated and document saved.", vbInformation
Exit Sub
HandleError:
' Handle errors
If Err.Number <> 0 Then
' Ignore known errors related to database engine
Debug.Print "Error: " & Err.Number
If Err.Number = 123 Or Err.Number = 112 Then
Err.Clear
Resume Next
Else
MsgBox "An unexpected error occurred: " & Err.Number & vbCr & Err.Description, vbExclamation
If Not wdDoc Is Nothing Then wdDoc.Close SaveChanges:=False
If wdApp.Documents.Count = 0 Then wdApp.Quit SaveChanges:=False
Set wdDoc = Nothing
Set wdApp = Nothing
End If
End If
End Sub