none
Automation error during mail merge in Excel VBA RRS feed

  • Question

  • Hi, the excel macro below is supposed to open a word document and automatically mail merge from the spreadsheet, but the macro is returning automation error unless the concerned Word document is already open. Is this due to any problems with rights and privileges. I am already logged in as administrator.

    Can some one provide any suggestions or advice on how to alter this code to prevent the errors. Thank you :)

    Error screens:

    http://imgur.com/a/epmGR

    http://imgur.com/a/zitah

    The program:

    Const wdFormLetters = 0, wdOpenFormatAuto = 0
    Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16
    
    Sub RunMerge()
        Dim wd As Object, wdocSource As Object
        Dim sh As Worksheet
        Dim Lrow As Long, i As Long
        Dim cdir As String, client As String, newname As String, newdirname As String
        Dim sSQL As String
    
        cdir = "C:\Users\Kamlesh\Desktop\"
    
        Set wd = CreateObject("Word.Application")
    
        Set wdocSource = wd.Documents.Open(cdir & "\master\Regen-booking.docx")
        Set sh = ActiveSheet
        strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
    
        With sh
            Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    
            For i = 2 To Lrow
                If Len(Trim(.Range("A" & i).Value)) <> 0 Then
                    client = .Cells(i, 1).Value
                    newname = "Regen Booking Form - " & client & ".docx"
                    'If Dir(cdir & "\" & client, vbDirectory) = "" Then
                        'MkDir cdir + client
                    'End If
                    'newdirname = cdir & "\" & client
                    wdocSource.MailMerge.MainDocumentType = wdFormLetters
    
                    '~~> Sample String
                    sSQL = "SELECT * FROM `Sheet1$` WHERE [Client Name] = '" & .Range("A" & i).Value & "'"
    
                    wdocSource.MailMerge.OpenDataSource Name:=strWorkbookName, _
                    AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatAuto, _
                    Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
                    SQLStatement:=sSQL
    
                    With wdocSource.MailMerge
                        .Destination = wdSendToNewDocument
                        .SuppressBlankLines = True
                        With .DataSource
                            .FirstRecord = wdDefaultFirstRecord
                            .LastRecord = wdDefaultLastRecord
                        End With
                        .Execute Pause:=False
                    End With
    
                    wd.ActiveDocument.SaveAs cdir & newname
                    wd.ActiveDocument.Close SaveChanges:=False
                End If
            Next i
        End With
    
        wdocSource.Close SaveChanges:=False
        'wd.Quit
    
        Set wdocSource = Nothing
        Set wd = Nothing
    End Sub

    Wednesday, August 10, 2016 4:17 AM

All replies

  • The following variation does work, provided the data worksheet is open.

    The macro will run quicker if Word is already open so if it is, use that instead of creating a new word object.

    Note that the syntax Document.Close SaveChanges:=Falseis wrong and should be

    Document.Close SaveChanges:=wdDoNotSaveChanges or simply Document.Close 0

    You might as well declare all the path as cdir.

    There is no correction for duplicated client names nor illegal filename characters. The latter in particular will bring the process crashing down if encountered.

    Option Explicit

    Sub RunMerge()
    Dim strWorkbookName As String
    Dim wd As Object, wdocSource As Object, wdDocTarget As Object
    Dim sh As Worksheet
    Dim Lrow As Long, i As Long
    Dim cdir As String, client As String, newname As String, newdirname As String
    Dim sSQL As String
    Dim fso As Object
    Dim bStarted As Boolean
    Const wdFormLetters = 0
    Const wdOpenFormatAuto = 0
    Const wdSendToNewDocument = 0
    Const wdDefaultFirstRecord = 1
    Const wdDefaultLastRecord = -16

        cdir = Environ("USERPROFILE") & "\Desktop\Master\"

        On Error Resume Next
        Set wd = GetObject(, "Word.Application")
        If Err Then
            Set wd = CreateObject("Word.Application")
            bStarted = True
        End If
        On Error GoTo 0
        wd.Visible = True 'at least while testing
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not fso.FileExists(cdir & "Regen-booking.docx") Then
            MsgBox cdir & "Regen-booking.docx does not exist!"
            Exit Sub
        End If
        Set wdocSource = wd.Documents.Open(cdir & "Regen-booking.docx")
        Set sh = ActiveSheet
        strWorkbookName = ActiveWorkbook.FullName

        With sh
            Lrow = .Range("A" & .Rows.Count).End(xlUp).Row

            For i = 2 To Lrow
                If Len(Trim(.Range("A" & i))) <> 0 Then
                    client = Trim(.Range("A" & i))
                    newname = cdir & "Regen Booking Form - " & client & ".docx"
                    
                    '~~> Sample String
                    sSQL = "SELECT * FROM `Sheet1$` WHERE [Client Name] = '" & client & "'"

                    With wdocSource.MailMerge
                        .OpenDataSource Name:=strWorkbookName, _
                                        AddToRecentFiles:=False, Revert:=False, Format:=wdOpenFormatAuto, _
                                        Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
                                        SQLStatement:=sSQL
                        .MainDocumentType = wdFormLetters

                        .Destination = wdSendToNewDocument
                        .SuppressBlankLines = True
                        With .DataSource
                            .FirstRecord = wdDefaultFirstRecord
                            .LastRecord = wdDefaultLastRecord
                        End With
                        .Execute Pause:=False
                    End With
                    Set wdDocTarget = wd.activedocument
                    wdDocTarget.SaveAs newname
                    wdDocTarget.Close 0
                End If
            Next i
        End With
        wdocSource.Close 0
        If bStarted Then wd.Quit
        Set wdocSource = Nothing
        Set wdDocTarget = Nothing
        Set wd = Nothing
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Thursday, August 11, 2016 8:07 AM