Как я могу пропустить пустые записи в VBA Excel слияния? - PullRequest
Новая
       112

Как я могу пропустить пустые записи в VBA Excel слияния?

0 голосов
/ 02 апреля 2020

Я хочу, чтобы мое VBA Excel Mail Merge с 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 не работает в этом случае. Так что любые советы будут с благодарностью.

Ответы [ 2 ]

1 голос
/ 07 апреля 2020

Спасибо, слегка ворчливый и макропод. Вы указали мне правильное направление, чтобы поймать эту ошибку. После того, как возиться с этим, эта ловушка работает :: 

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
0 голосов
/ 03 апреля 2020

Попробуйте: 

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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...