批量删除Word表格空白行

fanny2016

因为邮件合并生成的表格有很多空白行，我想要批量删除这些空白行，已经考虑了单元格可能有不可见字符了，还是删除不了，不知道问题在哪里，麻烦帮忙看看我的代码是哪里有问题呢


Sub DeleteRowsIfColumnsAreBlank()
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim tbl As Word.Table
    Dim row As Long
    Dim col As Long
    Dim isEmpty As Boolean

    ' 创建或获取Word应用程序对象
    Set wdApp = GetObject(, "Word.Application") ' 如果Word已打开
    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = True ' 可视化操作
    End If

    ' 直接对活动文档进行操作
    Set wdDoc = wdApp.ActiveDocument '

    ' 遍历文档中的所有表格
    For Each tbl In wdDoc.Tables
        For row = tbl.Rows.Count To 1 Step -1 ' 从最后一行开始向上遍历
            isEmpty = True ' 假设当前行指定列为空
            
            ' 检查第2到第5列是否都为空
            For col = 2 To 5
                ' 删除单元格中的不可见字符
                With tbl.Cell(row, col).Range
                    .Text = Replace(.Text, vbCr, "") ' 删除回车符
                    .Text = Replace(.Text, vbLf, "") ' 删除换行符
                    .Text = Replace(.Text, vbTab, "") ' 删除制表符
                    .NoProofing = True ' 忽略隐藏文本和格式标记
                    If Trim(.Text) <> "" Then
                        isEmpty = False ' 如果找到非空单元格，则该行不为空
                        Exit For ' 找到一个非空单元格后即可退出循环
                    End If
                    .NoProofing = False
                End With
            Next col
            
            ' 只要第2至5列都是空白，则删除这一行
            If isEmpty Then
                tbl.Rows(row).Delete
            End If
        Next row
    Next tbl

    ' 清理资源
    Set tbl = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

gwjkkkkk

写word宏，
Option Explicit
Sub test()
    Dim m&, n&, i&, j&, strJoin$
    On Error Resume Next
    With ActiveDocument.Tables(1)
        .Select
        m = .Range.Rows.Count
        n = .Range.Columns.Count
        For i = m To 1 Step -1
            strJoin = Empty
            For j = 1 To n
                strJoin = strJoin & Left(.Cell(i, j).Range.Text, Len(.Cell(i, j).Range.Text) - 2)
            Next j
            If Len(ReplaceEmptyTxt(strJoin)) = False Then
                .Cell(i, 2).Select
                Selection.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow
            End If
       Next i
    End With
End Sub

Function ReplaceEmptyTxt(EmptyTxt$) As String
    With CreateObject("VBScript.RegExp")
        .Global = True
        .IgnoreCase = True
        .Pattern = "[\u0001\u0009\u000a\u000d\u001c-\u0020\u007f-\u00fe]"
        ReplaceEmptyTxt = .Replace(EmptyTxt, "")
    End With
End Function

gwjkkkkk

word宏，代码审核中，请参考图片。。。

taller

fanny2016

taller 发表于 2024-2-19 03:15

谢谢啦，终于找到问题了

小花鹿

Sub DelRow3()
    Dim n&, s, i&, ss, tb As Table
    ss = Array("　", Chr(7), Chr(8), Chr(9), Chr(10), Chr(11), Chr(13), Chr(32))
    For Each tb In ActiveDocument.Tables
        With tb.Range
            n = .Cells.Count
            Do While n > 0
                With .Cells(n).Range
                    .Expand wdRow
                    n = n - .Cells.Count
                    s = .Text
                    For i = 0 To UBound(ss)
                        s = Replace(s, ss(i), "")
                    Next i
                    If s = "" Then
                        .Rows.Delete
                    End If
                End With
            Loop
        End With
    Next tb
End Sub

fanny2016

gwjkkkkk 发表于 2024-2-18 19:43
写word宏，
Option Explicit
Sub test()

谢谢啦，不过代码只能删除第一个表格，我稍微修改了一下，加入遍历所有表格：
' 定义一个名为TestAllTables的Sub过程，该过程用于遍历并处理Word文档中的所有表格
Sub TestAllTables()
    ' 声明变量
    Dim tbl As Table, m&, n&, i&, j&, strJoin$

    ' 启用错误处理，当发生错误时继续执行下一行代码
    On Error Resume Next

    ' 遍历当前活动文档中的所有表格
    For Each tbl In ActiveDocument.Tables
        ' 使用With语句对当前表格进行操作
        With tbl
            ' 选择当前表格
            .Select
            ' 获取表格的行数和列数
            m = .Range.Rows.Count
            n = .Range.Columns.Count
            
            ' 从最后一行开始向前遍历每一行
            For i = m To 1 Step -1
                ' 初始化合并文本字符串
                strJoin = Empty
               
                ' 遍历当前行的每一列
                For j = 1 To n
                    ' 将单元格内容添加到合并文本字符串中，但去掉最后一个字符（可能是换行符）
                    strJoin = strJoin & Left(.Cell(i, j).Range.Text, Len(.Cell(i, j).Range.Text) - 2)
                Next j
               
                ' 调用ReplaceEmptyTxt函数处理合并后的文本，如果处理后长度为0表示文本实质为空
                If Len(ReplaceEmptyTxt(strJoin)) = 0 Then
                    ' 选择当前行的第一列，并删除整行
                    .Cell(i, 1).Select
                    Selection.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow
                End If
            Next i
        End With
    Next tbl
End Sub

' 定义一个名为ReplaceEmptyTxt的函数，用于去除无效空白字符
Function ReplaceEmptyTxt(EmptyTxt$) As String
    ' 创建VBScript正则表达式对象
    With CreateObject("VBScript.RegExp")
        ' 设置全局匹配模式
        .Global = True
        ' 设置忽略大小写模式
        .IgnoreCase = True
        ' 设置要匹配并替换的无效空白字符范围
        .Pattern = "[\u0001\u0009\u000a\u000d\u001c-\u0020\u007f-\u00fe]"
        ' 执行替换操作并将结果返回
        ReplaceEmptyTxt = .Replace(EmptyTxt, "")
    End With
End Function

cai2532

删除WORD空格代码很有实用性。