VBA-執行階段錯誤438

Question

我在3種情況下使用VBA自動化mailmerge：請參見以下代碼：

（1）我需要根據每個工作表生成證書。

（2）證書名稱應分別為“上周四”和“ AAA” /“ BBB” /“ CCC”（基於工作表）。 例如。 25062015AAA.docx（用於工作表1），25062015BBB.docx（用於工作表2）和25062015CCC.docx（用於工作表3）。

但是目前，我的代碼是以不同的名稱保存了第一個生成的mailmerge。

否則會引發Runtime Error: 438 - Object required error當我像下面這樣編碼時， Runtime Error: 438 - Object required error 。 有人可以告訴我我要去哪里錯嗎？

一如既往地感謝您的幫助！

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

在這里，我為您解決問題的新方法。 我對其進行了修改，以使代碼清晰易懂。

我已經測試過，效果很好。

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 2

我假設由於您正在重新定義Word常量，因此該代碼是從Excel運行的。 如果是這種情況，則不能使用Word中的ThisDocument全局對象：

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

您需要獲取對通過郵件合並創建的新文檔的引用，或者在wd.Documents集合中找到它。

另外， 您無需將wd或wdoc設置為Nothing 。

Answer 3

您缺少Endifs 。 還嘗試此代碼。 我已經添加並更改了代碼。 讓我知道這是否是您想要的（ 未經測試 ）。 我剛剛更改了您的For循環。 我引入了一個新變量j ，用作新文件名的計數器。 我還在任何更改之處注釋了該代碼。

'
'~~> 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

對於宏，我主要使用了Nicolas的想法（“案例選擇”方法），並做了一些調整以適合我的文件。 希望這對某人有所幫助！ 非常感謝@ Nicolas，@ SiddharthRout，@ Comintern的努力:)

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