vba - 如果 Excel 中的单元格为空白,则从合并文档中删除行
问题描述
我使用 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 开始,看看我是否可以让它工作
解决方案
您的代码显然源自我在其他地方发布的代码,但在没有充分理解 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;您需要更改该部分代码以适应实际输出。
推荐阅读
- mysql - 如何创建 BEFORE INSERT 触发器
- apache-spark - Spark HashPartitioner 碰撞机制?
- scala - 循环遍历数据框列以形成嵌套数据框 - Spark
- postgresql - 哪个 Postgres 多 client_encoding 最佳实践?
- oauth-2.0 - 如何使用刷新令牌获取访问令牌?
- c# - 如何在不使用客户端 JSON.Parse 的情况下使用 JsonConvert.SerializeObject 和 JsonResult 进行 HTTP 响应
- sql - Oracle中所有标识列的列表
- python - 使用带有条件的 iat 查找值
- sql - 我怎样才能把一根绳子分成不同的部分,然后把每一块分成一层?
- javascript - JS - 如何在不重新加载网页的情况下删除活动的 eventListener