VBA-运行时错误438

Question

我正在使用VBA对以下三种情况自动执行邮件合并：请查看我的代码如下：

（1） 我需要根据每个工作表生成证书。

（2） 证书名称应为"Last Thursday"&分别为"AAA"/"BBB"/"CCC"（基于工作表）。例如，分别为25062015AA.docx（表1）、25062015BBB.docx（表2）和25062015CCC.docx（图3）。

然而，目前，我的代码要么用不同的名称保存第一个生成的mailmerge。

或者它抛出一个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