VBA – 运行时错误438
我正在使用VBA自动化mailmerge 3例：请参阅我的代码如下：
（1）我需要根据每个工作表生成证书。
（2）证书名称分别为“上周四”和“AAA”/“BBB”/“CCC”（以工作表为准）。 例如。 25062015AAA.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
在这里，我的新方法为您的问题。 我修改了代码清晰易懂。
我已经testing过了，效果很好。
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
我假设，因为你正在重新定义这个代码正在从Excel运行的Word常量。 如果是这种情况，则不能使用Word中的ThisDocument全局对象：
wd.ThisDocument.SaveAs "C:\" & LDate & "AAA" & ".docx"
您需要获得对邮件合并创build的新文档的引用，或者在wd.Documents集合中find它。
另外， 您不需要将wd或wdoc设置为Nothing 。
你正在失踪Endifs 。 也试试这个代码。 我已经添加并更改了代码。 让我知道如果这是你想要的（ 未经testing ）。 我刚刚改变了你的For循环。 我引入了一个新的variablesj ，用作新文件名的计数器。 我也评论过我曾经做过改变的代码。
' '~~> 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
对于这个macros，我主要使用了Nicolas的想法（“Case Select”方法），并且稍微调整了一下以适应我的文件。 希望这对某些人来说是有帮助的！ 非常感谢你@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