如何跳过VBA Excel邮件合并中的空记录？

Question

我希望我的VBA Excel Mail与Word合并以跳过空记录。当前，当我的查询中的数据记录变为空时，我收到运行时错误'5631'，指出“ Word无法将主文档与数据源合并，因为数据记录为空或数据记录与您的查询选项不匹配。”程序然后停在“ .Execute Pause：= False”。我当前的宏如下：

Sub RunMailMerge()

Dim fdObj As Object, wd As Object, wdocSource As Object
Dim strWorkbookName, strPath As String
Dim dteStart As Date, dteEnd As Date
Dim numUnit As Integer
Dim ptsArray As Variant
Dim strPtName As Variant
Dim i As Long, numLastPt As Long
Dim pctdone As Single

dteStart = ThisWorkbook.Sheets("Group Dates").Range("F2")
dteEnd = ThisWorkbook.Sheets("Group Dates").Range("F3")
strPath = ThisWorkbook.Path & "\" & Format(dteStart, "yyyyMM") & "-MonthlyNotes\"

ptsArray = ThisWorkbook.Worksheets("Patients").Range("PtNames").value
numLastPt = ThisWorkbook.Worksheets("Patients").Range("PtNames").Count
i = 1
ufProgress.LabelProgress.Width = 0

    'Make new folder if it does not exist
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(strPath) Then
        MsgBox "Found " & Format(dteStart, "yyyyMM") & "-MonthlyNotes. Ready to Print?",  vbInformation, "CPT Group Notes"
    Else
        fdObj.CreateFolder (strPath)
        MsgBox Format(dteStart, "yyyyMM") & "-MonthlyNotes has been created. Ready to Print?", vbInformation, "CPT Group Notes"
    End If

    ufProgress.Show

'iterating through each patient using For each loop.
For Each strPtName In ptsArray
    Application.ScreenUpdating = False

    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

    If Dir(ThisWorkbook.Path & PatientReportPath) <> "" Then

    pctdone = i / numLastPt

        With ufProgress
            .LabelCaption.Caption = "Processing Row " & i & " of " & numLastPt & " " & vbCrLf & strPtName
            .LabelProgress.Width = pctdone * (.FrameProgress.Width)
        End With

         Set wdocSource = wd.Documents.Open(ThisWorkbook.Path & PatientReportPath)
         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 `tblMailMerge` WHERE `Patient Name` = '" & strPtName & "' AND `DATE` BETWEEN #" & dteStart & "# AND #" & dteEnd & "# ORDER BY `DATE` DESC;"

             On Error GoTo noprint
             With wdocSource.MailMerge
                 .Destination = wdSendToNewDocument
                 .SuppressBlankLines = True
                 With .DataSource
                      .FirstRecord = wdDefaultFirstRecord
                      .LastRecord = wdDefaultLastRecord
                End With
               .Execute Pause:=False
            End With

            'The output document will automatically be the 'active' one
            wd.Visible = True

            With wd.ActiveDocument
                 wd.Run ("UniteRecords")
                .SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                'Close the output file
                .Close SaveChanges:=False
            End With

noprint:
            wdocSource.Close SaveChanges:=False
            Set wdocSource = Nothing
            Set wd = Nothing

            If i = numLastPt Then
                Unload ufProgress
                wd.Visible = False
                Shell "explorer.exe" & " " & strPath, vbNormalFocus
            End If
            i = i + 1

    Else
        MsgBox "File ' " & ThisWorkbook.Path & PatientReportPath & "' does not exist!"
    End If

    Application.ScreenUpdating = True

Next

End Sub

基本上，我想用这样的东西来修改代码

             If wdocSource.MailMerge.RecordCount > 0 Then
                 With wdocSource.MailMerge
                     .Destination = wdSendToNewDocument
                     .SuppressBlankLines = True
                     With .DataSource
                          .FirstRecord = wdDefaultFirstRecord
                          .LastRecord = wdDefaultLastRecord
                    End With
                   .Execute Pause:=False
                End With

                'The output document will automatically be the 'active' one
                wd.Visible = True

                With wd.ActiveDocument
                     wd.Run ("UniteRecords")
                    .SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
                    'Close the output file
                    .Close SaveChanges:=False
                End With

noprint:

                wdocSource.Close SaveChanges:=False
                Set wdocSource = Nothing
                Set wd = Nothing
            End If

但是RecordCount在这种情况下不起作用。因此，任何提示将不胜感激。

Answer 1

Sub RunMailMerge()
Application.ScreenUpdating = False
Dim fdObj As Object, wd As Object, wdocSource As Object
Dim strWorkbookName, strPath As String
Dim dteStart As Date, dteEnd As Date
Dim numUnit As Long, i As Long, numLastPt As Long
Dim ptsArray As Variant, strPtName As Variant
Dim pctdone As Single
With ThisWorkbook
  If Dir(.Path & PatientReportPath) <> "" Then
    strWorkbookName = .FullName
    dteStart = .Sheets("Group Dates").Range("F2").Text
    dteEnd = .Sheets("Group Dates").Range("F3").Text
    strPath = .Path & "\" & Format(dteStart, "YYYYMM") & "-MonthlyNotes\"
    ptsArray = .Worksheets("Patients").Range("PtNames").Value
    numLastPt = .Worksheets("Patients").Range("PtNames").Count

    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    If wd Is Nothing Then Set wd = CreateObject("Word.Application")
    On Error GoTo 0

    ufProgress.LabelProgress.Width = 0
    'Make new folder if it does not exist
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists(strPath) Then
      MsgBox "Found " & Format(dteStart, "yyyyMM") & "-MonthlyNotes. Ready to Print?", vbInformation, "CPT Group Notes"
    Else
      fdObj.CreateFolder (strPath)
      MsgBox Format(dteStart, "yyyyMM") & "-MonthlyNotes has been created. Ready to Print?", vbInformation, "CPT Group Notes"
    End If
    ufProgress.Show

    With wd
      .Visible = True
      .DisplayAlerts = wdAlertsNone
      Set wdocSource = .Documents.Open(strPath & PatientReportPath)
      With wdocSource
        With .MailMerge
          .MainDocumentType = wdFormLetters
          .Destination = wdSendToNewDocument
          .SuppressBlankLines = True
          'iterating through each patient using For each loop.
          For Each strPtName In ptsArray
            i = i + 1: pctdone = i / numLastPt
            With ufProgress
              .LabelCaption.Caption = "Processing Row " & i & " of " & numLastPt & " " & vbCrLf & strPtName
              .LabelProgress.Width = pctdone * (.FrameProgress.Width)
            End With
            .OpenDataSource Name:=strWorkbookName, AddToRecentFiles:=False, Revert:=False, _
              Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
              "Data Source=strWorkbookName;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
              SQLStatement:="SELECT * FROM `tblMailMerge` WHERE `Patient Name` = '" & strPtName & "' AND `DATE` BETWEEN #" & dteStart & "# AND #" & dteEnd & "# ORDER BY `DATE` DESC"
            With .DataSource
              .FirstRecord = wdDefaultFirstRecord
              .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
            'skip over missing record errors
            If Err.Number = 5631 Then
              Err.Clear
              GoTo NextRecord
            End If
            With wd.ActiveDocument
              wd.Run ("UniteRecords")
              .SaveAs Filename:=strPath & strPtName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
              'Close the output file
              .Close SaveChanges:=False
            End With
NextRecord:
          Next
        End With
        .Close SaveChanges:=False
      End With
    End With
  Else
    MsgBox "File ' " & .Path & PatientReportPath & "' does not exist!"
  End If
End With
Application.ScreenUpdating = True
End Sub