CODEWITHSUNDEEP
excelvbams-wordmailmerge
cravaus
cravaus

Reputation: 43

How can I skip empty records in VBA Excel mail merge?

I want my VBA Excel Mail Merge with Word to skip empty records. Currently when an the data record turns up empty from my query I get a Run-Time error '5631' stating that "Word could not merge the main document with the data source because the data records were empty or not data records matched your query options." The program then stalls at ".Execute Pause:=False". My current macro is as follows:

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

Essentially I would like to modify the code with something like this

             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

But RecordCount does not work in this case. So any tips will be greatly appreciated.

Upvotes: 1

Views: 1123

Answers (2)

Craig Tucker
Craig Tucker

Reputation: 1071

Thanks slightly snarky and macropod. You pointed me in the right direction of trapping that error. After messing around with it, this trap works::

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
             If Err.Number = 5631 Then
                Err.Clear
                GoTo noprint
             End If

             With wdocSource.MailMerge
                 .Destination = wdSendToNewDocument
                 .SuppressBlankLines = True
                 With .DataSource
                      .FirstRecord = wdDefaultFirstRecord
                      .LastRecord = wdDefaultLastRecord
                End With
                On Error Resume Next
                .Execute Pause:=False
                If Err.Number = 5631 Then
                  Err.Clear
                  GoTo noprint
                End If
                '.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

Upvotes: 0

macropod
macropod

Reputation: 13515

Try:

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

Upvotes: -1

Related Questions