Question

我正在尝试根据要约的详细信息生成要约信，并通过邮件将其合并。但是我希望我的输出为PDF格式，而不是word。

由于它以文字形式导出文件，因此我希望生成的最终输出是PDF。但是每当我尝试时，我都会遇到相同的错误。

出现系统错误＆H80004005未指定错误。

    Sub cmdAgree_Click()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.ReferenceStyle = xlA1

'    Sheets("DATA").Select
'    ActiveSheet.Range("A1").Select
'    Selection.End(xlDown).Select
'    row_ref = Selection.Row
'
'    Sheets("Mail Merge").Range("D4").Value = row_ref

    Sheets("Mail Merge").Select

    frst_rw = Sheets("Mail Merge").Range("D6").Value
    lst_rw = Sheets("Mail Merge").Range("D7").Value

'    ActiveWorkbook.Save

    'Loop to check if the start row is greater than the last actioned row
    If frst_rw = 1 Then
        MsgBox "Start row can't be 1. Please check and update to proceed!", vbCritical
        Exit Sub
    End If

    If Sheets("Data").Range("A" & frst_rw).Value = "" Then
        MsgBox "No Data to work upon. Please check the reference row used!!!"
        Exit Sub
    End If

'    If frst_rw <= Sheets("Mail Merge").Range("D5").Value And Sheets("Mail Merge").Range("D5").Value <> "" Then
'        MsgBox "Start from Row: Cant be less than last actioned row of data in the DATA tab." & vbNewLine _
'        & "Please check and update to proceed!", vbCritical
'        Exit Sub
'    End If

    'Loop to check if the last row to generate is greater than the total rows of data
'    If lst_rw > Sheets("Mail Merge").Range("D4").Value Then
'        MsgBox "End at Row: Cant be greater than total data rows in the DATA tab." & vbNewLine _
'        & "Please check and update to proceed!", vbCritical
'        Exit Sub
'    Else
    'Update the last actioned row for future reference
        Sheets("Mail Merge").Range("D5").Value = Sheets("Mail Merge").Range("D7").Value
'    End If

    'Loop though the start row and end row to generate the word documents for different candidates

    Dim wd As Object
    Dim wdocSource As Object

    Dim strWorkbookName As String

    On Error Resume Next

    'agreement_folder = ThisWorkbook.Path & "\Agreement Template\"

    For x = frst_rw - 1 To lst_rw - 1
  ' For x = frst_rw To lst_rw

    'This if condition tackles the choice of group company basis which the template gets selected

    If Sheets("DATA").Range("AS" & x + 1).Value = "APPLE" Then
        agreement_folder = ThisWorkbook.Path & "\Agreement Template - APPLE\"

    ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "BANANA" Then
        agreement_folder = ThisWorkbook.Path & "\Agreement Template - BANANA\"

    ElseIf Sheets("DATA").Range("AS" & x + 1).Value = "CHERRY" Then
        agreement_folder = ThisWorkbook.Path & "\Agreement Template - CHERRY\"
    End If

        Set wd = GetObject(, "Word.Application")

        If wd Is Nothing Then
            Set wd = CreateObject("Word.Application")
        End If

        On Error GoTo 0

        Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x + 1).Value)

        'Set wdocSource = wd.Documents.Open(agreement_folder & Sheets("DATA").Range("AL" & x).Value)

        strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
        wdocSource.MailMerge.MainDocumentType = wdFormLetters
        wdocSource.MailMerge.OpenDataSource _
                Name:=strWorkbookName, _
                AddToRecentFiles:=False, _
                Revert:=False, _
                Format:=wdOpenFormatAuto, _
                Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
                SQLStatement:="SELECT * FROM `DATA$`"

        With wdocSource.MailMerge
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = x
                .LastRecord = x
            End With
                .Execute Pause:=False
        End With

        Dim PathToSave As String
        PathToSave = ThisWorkbook.Path & "\" & "pdf" & "\" & Sheets("DATA").Range("B2").Value & ".pdf"
        If Dir(PathToSave, 0) <> vbNullString Then
        With wd.FileDialog(FileDialogType:=msoFileDialogSaveAs)
        If .Show = True Then
            PathToSave = .SelectedItems(1)
        End If
        End With
        End If
        wd.ActiveDocument.ExportAsFixedFormat PathToSave, 17 'The constant for wdExportFormatPDF


        'Sheets("Mail Merge").Select
        wd.Visible = True
        wdocSource.Close savechanges:=False
        wd.ActiveDocument.Close savechanges:=False

        Set wdocSource = Nothing
        Set wd = Nothing
    Next x

    Sheets("Mail Merge").Range("D6").ClearContents
    Sheets("Mail Merge").Range("D7").ClearContents

    MsgBox "All necessary Documents created and are open for your review. Please save and send!", vbCritical


End Sub

Answer 1

您的代码很简单，因此我不会尝试对其进行设置和支持。相反，我建议添加一个“监视窗口”，并检查结果。这应该可以帮助您找出问题并快速解决。

https://www.techonthenet.com/excel/macros/add_watch2016.php

尽管错误消息有时会令人误解，但它确实应该可以帮助您弄清错误消息，或者足够接近以回传有关正在发生的事情的非常具体的信息。

Excel MailMerge导出为PDF

1 个答案: