VBA - Runtime Error 438

Question

Я использую VBA для автоматизации MailMerge для 3-х случаях: Пожалуйста, смотрите мой код, как показано ниже:

(1) Мне нужно генерировать сертификаты, основанные на каждом листе.

(2) Сертификат должен быть «в прошлый четверг» & «AAA»/«BBB»/«CCC» (на основе рабочего листа) соответственно. Например. 25062015AAA.docx (для листа 1), 25062015BBB.docx (для листа 2) и 25062015CCC.docx (для листа 3) соответственно.

Однако в настоящее время мой код либо сохраняет 1-й сгенерированный почтовый ящик под разными именами.

Или он выбрасывает 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

Я предполагаю, что, поскольку вы переопределяете константы Word, которые этот код запускается из Excel. Если это так, то вы не можете использовать ThisDocument глобальный объект из Слова:

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

Вы должны либо получить ссылку на новый документ, созданный с помощью почтового слияния или найти его в wd.Documents коллекции.

Также you don't need to set wd or wdoc to Nothing.

Answer 2

Здесь мой новый подход к вашей проблеме. Я изменил его для четкого и понятного кода.

Я уже тестировал, он хорошо работает.

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 3

Вам не хватает Endifs. Также попробуйте этот код. Я добавил и изменил код. Дайте мне знать, если это то, что вы хотите (Untested). Я только что изменил цикл 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

Для макроса, я использовал в основном от идеи Никольского („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