VBA - Runtime Error 438

Question

I am using VBA to automate mailmerge for 3 cases : Please see my code as below :

(1) I need to generate certificates based on each worksheet.

(2) Certificate name should be "Last Thursday" & "AAA" / "BBB" / "CCC" (based on worksheet) respectively. Eg. 25062015AAA.docx (for sheet1), 25062015BBB.docx (for sheet2), and 25062015CCC.docx (for sheet3) respectively.

However currently, my code is either saving the 1st generated mailmerge under different names.

Or it throws a Runtime Error: 438 - Object required error, when I code it like below. Could someone kindly tell me where I'm going wrong?

Thank you for your help, as always!

Public Function LastThurs(pdat As Date) As Date

    LastThurs = DateAdd("ww", -1, pdat - (Weekday(pdat, vbThursday) - 1))

End Function

Sub Generate_Certificate()

    Dim wd As Object
    Dim i As Integer
    Dim wdoc As Object
    Dim FName As String
    Dim LDate As String
    Dim strWbName As String
    Const wdFormLetters = 0, wdOpenFormatAuto = 0
    Const wdSendToNewDocument = 0, wdDefaultFirstRecord = 1, wdDefaultLastRecord = -16

    LDate = Format(LastThurs(Date), "DDMMYYYY")

    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then
        Set wd = CreateObject("Word.Application")
    End If
    On Error GoTo 0

'Generate report using "Mailmerge" if any data available for Sheet1 to 3

    For Each Sheet In ActiveWorkbook.Sheets

        For i = 1 To 3
        If Sheet.Name = "Sheet" & i And IsEmpty(ThisWorkbook.Sheets("Sheet" & i).Range("A2").Value) = False Then

            Set wdoc = wd.documents.Open("C:\Temp" & i & ".docx")
            strWbName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
            wdoc.MailMerge.MainDocumentType = wdFormLetters

            wdoc.MailMerge.OpenDataSource _
                Name:=strWbName, _
                AddToRecentFiles:=False, _
                Revert:=False, _
                Format:=wdOpenFormatAuto, _
                Connection:="Data Source=" & strWbName & ";Mode=Read", _
                SQLStatement:="SELECT * FROM `Sheet" & i & "$`"

            With wdoc.MailMerge
                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                With .DataSource
                    .FirstRecord = wdDefaultFirstRecord
                    .LastRecord = wdDefaultLastRecord
                End With
            .Execute Pause:=False
            End With

            wd.Visible = True
            wdoc.Close SaveChanges:=False
            Set wdoc = Nothing

    'Saveas using Thursday Date & inside the folder (based on work sheet)
     If i = 1 Then
     wd.ThisDocument.SaveAs "C:\" & LDate & "AAA" & ".docx"
     If i = 2 Then
     wd.ThisDocument.SaveAs "C:\" & LDate & "BBB" & ".docx"
     Else
     wd.ThisDocument.SaveAs "C:\" & LDate & "CCC" & ".docx"

     End If                       
     End If

    Next

Next

Set wd = Nothing

End Sub

Answer 1

For the macro, I used mostly from Nicolas' idea ("Case Select" approach), and just tweaked a little bit to suit my file. Hope this is helpful for someone @ some point of time! Thank you so much @Nicolas, @SiddharthRout, @Comintern for your efforts :)

Sub Generate_Cert()

Dim wd As Object
Dim wdoc As Object
Dim i As Integer

Dim lastThursDay As String

Dim isInvalid As Boolean

Dim statement, fileSuffix, dataSoure As String
Dim aSheet As Worksheet

Const wdFormLetters = 0
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16

'Getting last THURSDAY
lastThursDay = Format(DateAdd("ww", -1, Date - (Weekday(Date, vbThursday) - 1)), "DDMMYYYY")

On Error Resume Next

'Check Word is open or not
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then

    'If Not open, open Word Application
    Set wd = CreateObject("Word.Application")
End If

On Error GoTo 0

'Getting dataSource
dataSoure = ThisWorkbook.Path & "\" & ThisWorkbook.Name

'Looping all sheet from workbook
For Each aSheet In ThisWorkbook.Sheets

    'If the first cell is not empty
    If aSheet.Range("A2").Value <> "" Then

        isInvalid = False

        'Check sheet for SQLStatement and save file name.
        Select Case aSheet.Name

            Case "Sheet1"
                statement = "SELECT * FROM `Sheet1$`"
                fileSuffix = "AAA"
                i = 1

            Case "Sheet2"
                statement = "SELECT * FROM `Sheet2$`"
                fileSuffix = "BBB"
                i = 2

            Case "Sheet3"
                statement = "SELECT * FROM `Sheet3$`"
                fileSuffix = "CCC"
                i = 3

            Case Else
                isInvalid = True

        End Select

        'If sheet should save as word
        If Not isInvalid Then

            'Getting the already set mailmerge template (word document)
            Set wdoc = wd.Documents.Open("C:\Temp" & i & ".docx")

            With wdoc.MailMerge

                .MainDocumentType = wdFormLetters

                .OpenDataSource Name:=dataSoure, AddToRecentFiles:=False, _
                                Revert:=False, Format:=wdOpenFormatAuto, _
                                Connection:="Data Source=" & dataSoure & ";Mode=Read", _
                                SQLStatement:=statement

                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                With .DataSource

                    .FirstRecord = wdDefaultFirstRecord
                    .LastRecord = wdDefaultLastRecord

                End With

                .Execute Pause:=False

            End With

            'wdoc.Visible = True
            wd.ActiveDocument.SaveAs "C:\" & lastThursDay & fileSuffix & ".docx"
            MsgBox lastThursDay & fileSuffix & " has been generated and saved"

            wdoc.Close SaveChanges:=True

        End If

    End If

Next aSheet

wd.Quit SaveChanges:=wdDoNotSaveChanges  '<~~ I put this because one of my word document was in use and I couldn't save it / use it otherwise!

End Sub

Answer 2

Here, my new approach for your problem. I modified it for code clear and easily understandable.

I already tested, it work well.

Dim wordApplication As Object
Dim wordDocument As Object

Dim lastThursDay As String

Dim isInvalid As Boolean

Dim statement, fileSuffix, dataSoure As String
Dim aSheet As Worksheet

Const wdFormLetters = 0
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16

'Getting last THURSDAY
lastThursDay = Format(DateAdd("ww", -1, Date - (Weekday(Date, vbThursday) - 1)), "DDMMYYYY")

On Error Resume Next

'Check Word is open or not
Set wordApplication = GetObject(, "Word.Application")

If wordApplication Is Nothing Then

    'If Not open, open Word Application
    Set wordApplication = CreateObject("Word.Application")

End If

On Error GoTo 0

'Getting dataSoure
dataSoure = ThisWorkbook.Path & "\" & ThisWorkbook.Name

'Looping all sheet from workbook
For Each aSheet In ThisWorkbook.Sheets

    'If the first cell is not empty
    If aSheet.Range("A2").Value <> "" Then

        isInvalid = False

        'Check sheet for SQLStatement and save file name.
        Select Case aSheet.Name

            Case "Sheet1"
                statement = "SELECT * FROM `Sheet1$`"
                fileSuffix = "AAA"

            Case "Sheet2"
                statement = "SELECT * FROM `Sheet2$`"
                fileSuffix = "BBB"

            Case "Sheet3"
                statement = "SELECT * FROM `Sheet3$`"
                fileSuffix = "CCC"

            Case Else
                isInvalid = True

        End Select

        'If sheet should save as word
        If Not isInvalid Then

            'Getting new word document
            Set wordDocument = wordApplication.Documents.Add

            With wordDocument.MailMerge

                .MainDocumentType = wdFormLetters

                .OpenDataSource Name:=dataSoure, AddToRecentFiles:=False, _
                                Revert:=False, Format:=wdOpenFormatAuto, _
                                Connection:="Data Source=" & dataSoure & ";Mode=Read", _
                                SQLStatement:=statement

                .Destination = wdSendToNewDocument

                .SuppressBlankLines = True

                With .DataSource

                    .FirstRecord = wdDefaultFirstRecord

                    .LastRecord = wdDefaultLastRecord

                End With

                .Execute Pause:=False

            End With

            wordDocument.SaveAs "C:\" & lastThursDay & fileSuffix & ".docx"

            wordDocument.Close SaveChanges:=True

        End If

    End If

Next aSheet

Answer 3

You are missing Endifs. Also Try this code. I have added and changed the code. Let me know if this is what you want (Untested). I have just changed your For loop. I introduced a new variable j which is used as a counter for the new file names. I also commented the code where ever I made a change.

'
'~~> Rest of the code
'

Dim j As Long '<~~ Added This
Dim aSheet As Worksheet '<~~ Do not use Sheet as it is a reserved word in VBA

For Each aSheet In ThisWorkbook.Sheets
    j = j + 1 '<~~ Added This

    For i = 1 To 3
        If aSheet.Name = "Sheet" & i And _
        IsEmpty(ThisWorkbook.Sheets("Sheet" & i).Range("A2").Value) = False Then

            Set wdoc = wd.documents.Open("C:\Temp" & i & ".docx")
            strWbName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
            wdoc.MailMerge.MainDocumentType = wdFormLetters

            wdoc.MailMerge.OpenDataSource _
            Name:=strWbName, AddToRecentFiles:=False, _
            Revert:=False, Format:=wdOpenFormatAuto, _
            Connection:="Data Source=" & strWbName & ";Mode=Read", _
            SQLStatement:="SELECT * FROM `Sheet" & i & "$`"

            With wdoc.MailMerge
                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                With .DataSource
                    .FirstRecord = wdDefaultFirstRecord
                    .LastRecord = wdDefaultLastRecord
                End With
                .Execute Pause:=False
            End With

            wd.Visible = True
            wdoc.Close SaveChanges:=False
            Set wdoc = Nothing

            '~~> Changed This
            If j = 1 Then
               wd.ActiveDocument.SaveAs "C:\" & LDate & "AAA" & ".docx"
            ElseIf j = 2 Then
               wd.ActiveDocument.SaveAs "C:\" & LDate & "BBB" & ".docx"
            Else
               wd.ActiveDocument.SaveAs "C:\" & LDate & "CCC" & ".docx"
            End If
            Exit For '<~~ Added This
        End If
    Next i
Next aSheet

Answer 4

I'm assuming that since you are re-defining the Word constants that this code is being run from Excel. If that is the case, you can't use the ThisDocument global object from Word:

wd.ThisDocument.SaveAs "C:\" & LDate & "AAA" & ".docx"

You need to either obtain a reference to the new document created by the mail merge or find it in the wd.Documents collection.

Also, you don't need to set wd or wdoc to Nothing.