Question

我已经使用VBA创建了一个邮件合并，该邮件合并会自动将每个条目另存为自己的PDF。我遇到的唯一问题是excel中的某些单元格是空的并且空白。表格中列出了用于邮件合并的文档，以使其看起来更好，并且以这种方式分隔合并域更加容易。我想创建一些代码，以便如果单元格为空，而不是通过空格来代替，而是从合并文档的表中删除该行。我一直在玩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 $0.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) = "$0.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

请注意，我假设您的“空”结果将输出为$ 0.00；您需要更改部分代码以适合实际输出。

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

1 个答案: