VBA - Ошибка выполнения 438

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

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

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

Однако в настоящее время мой код либо сохраняет 1-й сгенерированный 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

excel vba mailmerge
person Dragon Warrior    schedule 02.07.2015    source источник
comment
Что делает LastThurs(Date)? Почему бы просто не LDate = Format(Date, "DDMMYYYY")   -  person Siddharth Rout    schedule 02.07.2015
comment
@SiddharthRout Здравствуйте, я использовал LastThurs как функцию, чтобы найти дату последнего четверга. Затем я вызываю его снова внутри подпрограммы, чтобы отформатировать его так, как я хочу. Если я поставлю его как LDate = Format (Date, DDMMYYYY), он просто покажет сегодняшнюю дату, верно? Если есть лучший способ найти дату в последний четверг, пожалуйста, дайте мне знать :) Спасибо и ура :)   -  person Dragon Warrior    schedule 02.07.2015

Ответы (4)


arrow_upward
1
arrow_downward

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

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

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
person R.Katnaan    schedule 02.07.2015
comment
Николас! Большое спасибо!!! Ваш код работал как шарм (я немного отредактировал, ну тут и там). Но для общей концепции (оператор Case) был действительно полезен! Еще раз большое спасибо :) - person Dragon Warrior; 02.07.2015
comment
Хорошо, DragonWarrior! Мой ответ правильный? Если весь наш ответ не соответствует вашим требованиям, вы должны опубликовать правильный ответ на свой вопрос для других, кто нашел проблему, как вы. - person R.Katnaan; 03.07.2015
comment
Он основан на вашем коде (по большей части). Так что я не уверен, стоит ли публиковать это как отдельный ответ. Но сначала я его выложу. Еще раз спасибо за вашу идею и усилия! - person Dragon Warrior; 03.07.2015
comment
Я внезапно получаю ошибку 5631 в строке .Execute Pause:=False. Когда я попытался найти основную причину, было упомянуто, что эта ошибка возникает из-за неквалифицированных объектов / параметров. Как вы думаете, используются ли в этом коде какие-либо неквалифицированные параметры? И есть идеи, как разрешить? Извините за неприятности. - person Dragon Warrior; 22.02.2016
comment
Извини, воин, я сейчас так занят и не могу проверить это снова. Когда время, когда я публикую ответ, он хорошо работает для требования этого вопроса. Я уже тестировал снова и снова. Это идеально подходит для меня. извиняюсь. - person R.Katnaan; 14.03.2016

arrow_upward
0
arrow_downward

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

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

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

Кроме того, вам не нужно устанавливать wd или wdoc на Nothing.

person Comintern    schedule 02.07.2015
comment
Извините, я все еще новичок в программировании на VBA. Был бы признателен, если бы вы могли показать мне, как получить ссылку на новый документ / найти его в коллекции wd.Documents. Спасибо!! - person Dragon Warrior; 02.07.2015

arrow_upward
0
arrow_downward

Вам не хватает 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
person Siddharth Rout    schedule 02.07.2015

arrow_upward
0
arrow_downward

Для макроса я использовал в основном идею Николаса (подход «Выбор случая») и немного изменил его, чтобы он соответствовал моему файлу. Надеюсь, это будет полезно для кого-то @ когда-нибудь! Большое спасибо @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
person Dragon Warrior    schedule 03.07.2015