运行时错误5631

Question

我正在尝试使用Excel主数据文件中的记录来生成证书。 我的编码使我每隔一段时间就会遇到一个VBA错误：“运行时错误-5631； Word无法将主文档与数据源合并，因为数据记录为空或没有数据记录与您的查询选项匹配”。

对于某些数据，代码有效，而在大多数情况下，它在行中引发错误.Execute Pause:=False
文件中有记录，因此我知道查询本身存在问题。

其他资讯：
Temp1 = Cookies邮件合并词模板，
Temp2 =巧克力邮件合并Word模板，
Temp3 =饮料邮件合并Word模板
Sheet1 = Cookies销售excel数据，
Sheet2 = Chocolates销售Excel数据，
Sheet3 =饮料销售Excel数据

我完整的代码：

Sub Generate_Cert()

Dim wd As Object
Dim wdoc As Object
Dim i As Integer
Dim isInvalid As Boolean

Dim statement, fileSuffix, datasource As String
Dim aSheet As Worksheet
Dim cDir As String
Dim wdName As String

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

SalesDate = Format(Worksheets("SalesMaster").Cells(2, "B").Value, "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
datasource = 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 = " Cookies Sales"
                i = 1

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

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

            Case Else
                isInvalid = True

        End Select

        'If sheet should save as word
        If Not isInvalid Then

            'Getting new word document
            Set wdoc = wd.Documents.Open("C:\Desktop\Sales Certs\Temp" & i & ".docx")

            With wdoc.MailMerge

                .MainDocumentType = wdFormLetters

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

                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                With .datasource

                    .FirstRecord = wdDefaultFirstRecord
                    .LastRecord = wdDefaultLastRecord

                End With

                .Execute Pause:=False

            End With

            'wdoc.Visible = True
            wdName = SalesDate & fileSuffix & ".docx"
            cDir = ActiveWorkbook.Path + "\"
            wd.ActiveDocument.SaveAs cDir + wdName
            MsgBox SalesDate & fileSuffix & " has been generated and saved"

            'wdoc.SaveAs Filename:=wdoc.Name
            wdoc.Close SaveChanges:=True

        End If

    End If

Next aSheet

wd.Quit SaveChanges:=wdDoNotSaveChanges

End Sub

Answer 1

发生此错误的原因是在执行Mailmerge之前未保存我的源excel文档。 无需保存Word文档，因为在执行Mailmerge之前无需进行任何预处理。

所以我基本上将wBook声明为workbook并添加了以下内容： wBook.Save

Sub Generate_Cert()

Dim wd As Object
Dim wdoc As Object
Dim i As Integer
Dim isInvalid As Boolean

Dim statement, fileSuffix, datasource As String
Dim wBook As Workbook
Dim aSheet As Worksheet
Dim cDir As String
Dim wdName As String

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

wBook.save '<~~~~~~~ SAVE BEFORE MAILMERGE STARTS
SalesDate = Format(Worksheets("SalesMaster").Cells(2, "B").Value, "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
datasource = 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 = " Cookies Sales"
                i = 1

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

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

            Case Else
                isInvalid = True

        End Select

        'If sheet should save as word
        If Not isInvalid Then

            'Getting new word document
            Set wdoc = wd.Documents.Open("C:\Desktop\Sales Certs\Temp" & i & ".docx")

            With wdoc.MailMerge

                .MainDocumentType = wdFormLetters

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

                .Destination = wdSendToNewDocument
                .SuppressBlankLines = True
                With .datasource

                    .FirstRecord = wdDefaultFirstRecord
                    .LastRecord = wdDefaultLastRecord

                End With

                .Execute Pause:=False

            End With

            'wdoc.Visible = True
            wdName = SalesDate & fileSuffix & ".docx"
            cDir = ActiveWorkbook.Path + "\"
            wd.ActiveDocument.SaveAs cDir + wdName
            MsgBox SalesDate & fileSuffix & " has been generated and saved"

            'wdoc.SaveAs Filename:=wdoc.Name
            wdoc.Close SaveChanges:=True

        End If

    End If

Next aSheet

wd.Quit SaveChanges:=wdDoNotSaveChanges

End Sub