求助各位老师,如何批量识别删除word表格内多余空白行

Comet_95

真诚求助各位老师.有word几百件,表内房屋状况处有多余空白行,多则4行,少则1行.需要按照要求需要删除此处的空白行.






我的思路是按行列坐标识别此处Cell内容是否为空,然后Cell所在的整行删除

房屋状况处五行Cell坐标是(13,2)/(14,2)/(15,2)/(16,2)/(17,2)
但是代码思路还不成熟,望各位老师指点,给予代码进行参考学习
鲜花奉上
信息调查表.rar (64.16 KB, 下载次数: 17)

2021-7-9 23:13 上传

点击文件名下载附件

Comet_95

1. Sub shanchu()
   
2. Dim mypath As String, docname As String
   
3. Dim doc As Document
   
4. mypath = ActiveDocument.Path
   
5. docname = Dir(mypath & "" & "*.docx")
   
6. Application.DisplayAlerts = False
   
7. Do While docname <> ""
   
8.     If docname <> ThisDocument.Name Then
   
9.         Set doc = Documents.Open(mypath & "" & docname)
   
10.         With doc
    
11.             If doc.Tables(1).Cell(17, 2).Range.Text <> "0005" Then
    
12.                 If doc.Tables(1).Cell(16, 2).Range.Text <> "0004" Then
    
13.                     If doc.Tables(1).Cell(15, 2).Range.Text <> "0003" Then
    
14.                         If doc.Tables(1).Cell(14, 2).Range.Text <> "0002" Then
    
15.                             doc.Tables(1).Rows(17).Delete
    
16.                             doc.Tables(1).Rows(16).Delete
    
17.                             doc.Tables(1).Rows(15).Delete
    
18.                             doc.Tables(1).Rows(14).Delete
    
19.                         Else
    
20.                             doc.Tables(1).Rows(17).Delete
    
21.                             doc.Tables(1).Rows(16).Delete
    
22.                             doc.Tables(1).Rows(15).Delete
    
23.                         End If
    
24.                     Else
    
25.                         doc.Tables(1).Rows(17).Delete
    
26.                         doc.Tables(1).Rows(16).Delete
    
27.                     End If
    
28.                 Else
    
29.                     doc.Tables(1).Rows(17).Delete
    
30.                 End If
    
31.             End If
    
32.         End With
    
33.         doc.Close savechanges:=True
    
34.     End If
    
35. docname = Dir
    
36. Loop
    
37. Application.DisplayAlerts = False
    
38. End Sub
    

复制代码

这是我个人的思路,但是运行通不过,希望各位老师指教!

zhanglei1371

不出意外的话，本题无解。除非sylun大师愿意出手解决。

sylun

对这种不规则的表格不能直接对行进行delete。可试作如下修改

1. Sub shanchu()
   
2.     Dim i%, n%, mypath$, docname$
   
3.     Dim doc As Document
   
4.    
   
5.     mypath = ActiveDocument.Path
   
6.     docname = Dir(mypath & "\*.docx")
   
7.     Application.ScreenUpdating = False
   
8.     Do While docname <> ""
   
9.         If docname <> ThisDocument.Name Then
   
10.             Set doc = Documents.Open(mypath & Chr(92) & docname)
    
11.             With doc.Tables(1)  '假设各文档都有一个相同格式的表格
    
12.                 For i = 17 To 14 Step -1
    
13.                     If Val(.Cell(i, 2).Range.Text) < 1 Then .Cell(i, 2).Delete 2 Else Exit For
    
14.                 Next
    
15.             End With
    
16.             n = n + 1
    
17.             doc.Close True
    
18.         End If
    
19.         docname = Dir
    
20.     Loop
    
21.     MsgBox "共处理了" & n & "个文档"
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

zmj9151

____________
Sub DeleteEmptyRows()
Dim doc As Document
Dim t As Table

Set doc = ActiveDocument
Set t = doc.Tables(1)


a1 = Selection.Information(wdEndOfRangeRowNumber)

t.Range.Select
With Selection.Find
    .Text = "房屋权界线示意图"
    .Execute
   
    a2 = Selection.Information(wdEndOfRangeRowNumber)
End With


For i = a2 - 1 To 12 Step -1
    t.Cell(i, 2).Select
    Selection.SelectRow
   
    s = Selection.Text
    s = Replace(s, Chr(7), "")
    s = Replace(s, Chr(13), "")
    If Len(s) = 0 Then
        Selection.Cells.Delete ShiftCells:=wdDeleteCellsEntireRow
        Selection.TypeBackspace
    Else
        Exit For
    End If
Next
End Sub

413191246se

* 请 楼主 备份原文件后试用下面的宏：（如果想中途停止执行宏，请按 Ctrl + PauseBreak 组合键）

1. Sub aaaa_delete_Empty_Lines_LoopFolder_xiaohualu()
   
2.     Dim d, n&, m&, x&, mydir, dk, doc As Document, i&
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     d(SelectFolder) = ""
   
5.     Do While n < d.Count
   
6.         dk = d.keys
   
7.         mydir = Dir(dk(n), vbDirectory)
   
8.         Do While mydir <> ""
   
9.             If mydir <> "." And mydir <> ".." Then
   
10.                 If GetAttr(dk(n) & mydir) = vbDirectory Then
    
11.                     d(dk(n) & mydir & "") = ""
    
12.                     m = m + 1
    
13.                 Else
    
14.                     x = x + 1
    
15.                     If dk(n) & mydir Like "*.doc*" Then
    
16.                         Set doc = Documents.Open(filename:=dk(n) & mydir)
    
17.                         '-----------------------------------------------------
    
18.                         Do
    
19. re:
    
20.                             doc.Tables(1).Cell(13, 2).Select
    
21.                             With Selection
    
22.                                 .MoveDown Unit:=wdLine, Count:=1
    
23.                                 Do
    
24.                                     If .Cells(1).Range Like "*[0-9]*" Then
    
25.                                         .MoveDown Unit:=wdLine, Count:=1
    
26.                                     Else
    
27.                                         If .Next(4, 1) Like "/*" Then Exit Sub
    
28.                                         .Rows.Delete
    
29.                                         GoTo re
    
30.                                     End If
    
31.                                 Loop
    
32.                             End With
    
33.                         Loop
    
34.                         '------------------------------------------------------
    
35.                         doc.Close SaveChanges:=wdSaveChanges
    
36.                         i = i + 1
    
37.                     End If
    
38.                 End If
    
39.             End If
    
40.             mydir = Dir
    
41.         Loop
    
42.         n = n + 1
    
43.     Loop
    
44.     Set d = Nothing
    
45.     Set dk = Nothing
    
46.     MsgBox "&#206;&#196;&#188;t&#188;D°üo&#172; " & x & " &#184;&#246;&#206;&#196;&#188;t￡&#161;" & m & " &#184;&#246;×ó&#206;&#196;&#188;t&#188;D￡&#161;" & vbCr & "12′|àí Word &#206;&#196;μμ(*.docx/*.doc) " & i & " &#184;&#246;￡&#161;", 0 + 48
    
47. End Sub
    
48. Function SelectFolder() As String
    
49.     With Application.FileDialog(msoFileDialogFolderPicker)
    
50.         If .Show Then SelectFolder = .SelectedItems(1) & "" Else End
    
51.     End With
    
52.     If MsgBox("Are you sure to process " & """" & SelectFolder & """" & " ?", 4 + 16) = vbNo Then End
    
53. End Function

复制代码