VBA - 运行时错误438 [英] VBA - Runtime Error 438

问题描述

我正在使用VBA自动化mailmerge 3种情况：
请参阅我的代码如下：

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

（1）我需要生成基于每个工作表。

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

（2）证书名称应为上周四& AAA/BBB/CCC（基于工作表）。例如。 25062015AAA.docx（for sheet1），25062015BBB.docx（for sheet2）和25062015CCC.docx（for sheet3）。

(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.

但是，目前，我的代码正在保存第一个生成的mailmerge不同的名字。

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

或者它会抛出一个运行时错误：438 - 对象需要的错误，当我代码如下。有人可以告诉我哪里错了吗？

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

推荐答案

，我的新方法为您的问题。我修改了代码清楚，易于理解。

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

这篇关于VBA - 运行时错误438的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！