word批量删除表格空白行

辉龙52330

如图所示，运用word的引用功能批量生成测试报告，但是出现个问题：不同的样品测试报告的项目不一样就导致表格会用空白，请求各位大神怎么用B=VBA批量删除同文件夹下word文件的空白行，非常感谢（个人用WPS软件，最好能兼容）。

taller

辉龙52330

taller 发表于 2023-4-4 22:44

[img]感谢大神在百忙中解答，代码试过能用，但是删除只能对当前文件的空白表格。相同文件夹下还有一百多份文件没动静。然后我修改大神的代码做个文件循环删除，运行出现附图报错，能帮忙看下哪里不对吗？感谢感谢感谢
[/img][img][/img]

辉龙52330

辉龙52330 发表于 2023-4-5 22:28
[/img]

Sub DeleteEmptyRowsInTables()
Dim tbl As Table
Dim i As Integer, ff, MyPath, k
MyPath = ActiveDocument.Path & "\"
ff = Dir(MyPath & "*.docx*")
   k = 2
    Do While ff <> ""
For Each tbl In ActiveDocument.Tables
i = i + 1
'Check if table is not the first table
If i > 1 Then
  'Loop through each row in table
Dim row As row
For Each row In tbl.Rows
'Check if second to fourth column is empty
If Len(Trim(row.Cells(2).Range.Text)) = 2 _
And Len(Trim(row.Cells(3).Range.Text)) = 2 _
And Len(Trim(row.Cells(4).Range.Text)) = 2 Then
'Delete row if all columns are empty
row.Delete
End If
Next row
End If
Next tbl
k = k + 1
Loop
MsgBox "删除空白表格完成！"
End Sub

辉龙52330

辉龙52330 发表于 2023-4-5 22:28
[/img]

我自己修改运行异常的代码如下：

Sub DeleteEmptyRowsInTables()
Dim tbl As Table
Dim i As Integer, ff, MyPath, k
MyPath = ActiveDocument.Path & "\"
ff = Dir(MyPath & "*.docx*")
   k = 2
    Do While ff <> ""
For Each tbl In ActiveDocument.Tables
i = i + 1
'Check if table is not the first table
If i > 1 Then
  'Loop through each row in table
Dim row As row
For Each row In tbl.Rows
'Check if second to fourth column is empty
If Len(Trim(row.Cells(2).Range.Text)) = 2 _
And Len(Trim(row.Cells(3).Range.Text)) = 2 _
And Len(Trim(row.Cells(4).Range.Text)) = 2 Then
'Delete row if all columns are empty
row.Delete
End If
Next row
End If
Next tbl
k = k + 1
Loop
MsgBox "删除空白表格完成！"
End Sub

zyhui1961

taller 发表于 2023-4-4 22:44

老师您好！
请你帮忙：下面是我录制的宏的内容，单独运行没有问题。
    Sheets("成绩查询").Select
    Range("AA5:AA69").Select
    Selection.Copy '复制文本
    Range("Z5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=F
alse, Transpose:=False '粘贴数值
    Range("Z5").Select
可是我加一个工作表事件，为什么就运行不了？
Private Sub Worksheet_Change(ByVal Target As Range) '工作表触发事件
    Set Myrng = Range("A1")   
    Sheets("成绩查询").Select
    Range("AA5:AA69").Select'老是从这个地方开始卡住了
    Selection.Copy '复制文本
    Range("Z5").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False '粘贴数值
    Range("Z5").Select
End Sub
    Range("Z5").Select
End Sub