Question

我使用VBA自动化mailmerge 3个案例：请参阅我的代码如下：

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

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

但是目前，我的代码是以不同的名称保存第一个生成的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

我假设您正在重新定义从Excel运行此代码的Word常量。如果是这种情况，则无法使用Word中的ThisDocument全局对象：

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

您需要获取对邮件合并创建的新文档的引用，或者在wd.Documents集合中找到它。

另外，you don't need to set wd or wdoc to 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，@ SiddharthRout，@ Citomin为您的努力：）

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

VBA - 运行时错误438

4 个答案: