如果 Excel 中的单元格为空，则从合并文档中删除行

Question

我使用 VBA 创建了一个邮件合并，它会自动将每个条目保存为自己的 PDF。我运行遇到的唯一问题是 excel 中的一些单元格是空的，并且从空白中拉出。用于邮件合并的文档在 table 中列出，以使其看起来更好，并且通过这种方式分隔合并字段更容易。我想创建一些代码，这样如果一个单元格为空，它不会通过空白 space，而是从合并文档的 table 中删除该行。我一直在玩 MyDoc.tables(1).Rows().Delete 但似乎无法让它工作。感谢任何帮助。

Sub RunMailMerge()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim StrFolder As String, StrName As String, i As Long, j As Long
Dim strWorkbookName As String: strWorkbookName = ThisWorkbook.FullName
Const StrNoChr As String = """*./\:?|": StrName = "Certificate.docx"
StrFolder = ThisWorkbook.Path & Application.PathSeparator

  If Dir(StrFolder & strDocNm) = "" Then Exit Sub
    With wdApp
    'Disable alerts to prevent an SQL prompt
    .DisplayAlerts = wdAlertsNone
    'Display Word - change this to False once the code is running correctly
    .Visible = False
    'Open the mailmerge main document - set Visible:=True for testing
    Set wdDoc = .Documents.Open(Filename:=StrFolder & StrName, ReadOnly:=True, 
    AddToRecentFiles:=False, Visible:=False)

    With wdDoc
    With .MailMerge
      'Define the mailmerge type
      .MainDocumentType = wdFormLetters
      'Define the output
      .Destination = wdSendToNewDocument
      .SuppressBlankLines = True
      'Connect to the data source
      .OpenDataSource Name:=strWorkbookName, ReadOnly:=True, _
      LinkToSource:=False, AddToRecentFiles:=False, _
      Format:=wdOpenFormatAuto, _
      Connection:="Provider=Microsoft.ACE.OLEDB.16.0;" & _
      "User ID=Admin;Data Source=strWorkbookName;" & _
      "Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
      SQLStatement:="SELECT * FROM `Sheet1$`", _
      SubType:=wdMergeSubTypeAccess

  'Process all eligible records
  For i = 1 To .DataSource.RecordCount
    With .DataSource
    .FirstRecord = i
    .LastRecord = i
    .ActiveRecord = i
    'Exit if the field to be used for the filename is empty
    If Trim(.DataFields("PropertyRef")) = "" Then Exit For

    Call DeleteBlankRows

    'StrFolder = .DataFields("Folder") & Application.PathSeparator
    StrName = .DataFields("PropertyRef")
  End With  

.Execute Pause:=False

'Clean up the filename
  For j = 1 To Len(StrNoChr)
  StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
    Next
  StrName = "Certificate - " & Trim(StrName)
  Save as a PDF
    wdApp.ActiveDocument.SaveAs Filename:=StrFolder & StrName & ".pdf", _
    FileFormat:=wdFormatPDF, AddToRecentFiles:=False
    wdApp.ActiveDocument.Close SaveChanges:=False
  Next i

    'Disconnect from the data source
    .MainDocumentType = wdNotAMergeDocument
    End With

  'Close the mailmerge main document
  .Close False
  End With

  'Restore the Word alerts
  .DisplayAlerts = wdAlertsAll
  'Exit Word
  .Quit
  End With

  Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

新建宏

Sub DeleteBlankRows

Dim MyDoc As Object
Dim i As Integer

Set MyDoc = MyMail.GetInspector.WordEditor

  i = 2
  Do Until .Range("C" & i) = ""
    If .Range("C" & i) = "" Then MyDoc.tables(1).Rows(8).Delete
  i = i + 1
Loop

End Sub

我只尝试了 1 个 IF 开始，看看我是否可以让它工作

Answer 1

您的代码显然是从我在其他地方发布的代码派生而来的，但在没有充分理解 Word VBA 的情况下进行了修改。尝试：

Sub RunMailMerge()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim StrFolder As String, StrName As String, i As Long, j As Long, r As Long
Dim strWorkbookName As String: strWorkbookName = ThisWorkbook.FullName
Const StrNoChr As String = """*./\:?|": StrName = "Certificate.docx"
StrFolder = ThisWorkbook.Path & Application.PathSeparator
If Dir(StrFolder & StrName) = "" Then Exit Sub
With wdApp
  'Disable alerts to prevent an SQL prompt
  .DisplayAlerts = wdAlertsNone
  'Display Word - change this to False once the code is running correctly
  .Visible = False
  'Open the mailmerge main document - set Visible:=True for testing
  Set wdDoc = .Documents.Open(Filename:=StrFolder & StrName, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
  With wdDoc.MailMerge
    'Define the mailmerge type
    .MainDocumentType = wdFormLetters
    'Define the output
    .Destination = wdSendToNewDocument
    .SuppressBlankLines = True
    'Connect to the data source
    .OpenDataSource Name:=strWorkbookName, ReadOnly:=True, LinkToSource:=False, AddToRecentFiles:=False, _
      Format:=wdOpenFormatAuto, Connection:="Provider=Microsoft.ACE.OLEDB.16.0;" & _
      "User ID=Admin;Data Source=strWorkbookName;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
      SQLStatement:="SELECT * FROM `Sheet1$`", SubType:=wdMergeSubTypeAccess
    'Process all eligible records
    For i = 1 To .DataSource.RecordCount
      With .DataSource
        .FirstRecord = i
        .LastRecord = i
        .ActiveRecord = i
        'Exit if the field to be used for the filename is empty
        If Trim(.DataFields("PropertyRef")) = "" Then Exit For
        'StrFolder = .DataFields("Folder") & Application.PathSeparator
        StrName = .DataFields("PropertyRef")
      End With
      .Execute Pause:=False
      'Clean up the filename
      For j = 1 To Len(StrNoChr)
        StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
      Next
      StrName = "Certificate - " & Trim(StrName)
      'Delete table rows with [=10=].00 values
      With wdApp.ActiveDocument
        With .Tables(1)
          For r = 33 To 14 Step -1
            Select Case r
              Case 20, 28, 29
              Case Else: If Split(.Cell(r, 3).Range.Text, vbCr)(0) = "[=10=].00" Then .Rows(i).Delete
            End Select
          Next
        End With
        'Save as a PDF
        .SaveAs Filename:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
        .Close SaveChanges:=False
      End With
    Next i
    'Disconnect from the data source
    .MainDocumentType = wdNotAMergeDocument
  End With
  'Close the mailmerge main document
  wdDoc.Close False
  'Restore the Word alerts
  .DisplayAlerts = wdAlertsAll
  'Exit Word
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

请注意，我假设您的 'empty' 结果将输出为 0.00 美元；您需要更改那部分代码以适应实际输出。

如果 Excel 中的单元格为空，则从合并文档中删除行

Delete Rows From Merge Document If Cell In Excel Is Blank

vba

ms-word

mailmerge