批量删除单无格空行

天空飘过啥 · 发表于 2018-5-20 22:12

表格较大，其中还有很多的空行，如图
用什么办公指导空行全删除

先谢谢了

TIM截图20180520220825.png

最后变成这样

删表格空行.rar (5.86 KB, 下载次数: 11)

pureshadow · 发表于 2018-5-21 14:48

查找^p^p，替换为^p，多替换几次。

duquancai · 发表于 2018-5-21 17:05

可以。。。。。。。。

ming0018 · 发表于 2018-5-21 17:27

Sub 删除表格空行()
Dim myDoc As Document
Dim myTable As Table
Dim myCell As Cell
Dim myCellRng As Range
Dim myPar As Paragraph
Dim Rng As Range
Set myDoc = ActiveDocument
For Each myTable In myDoc.Tables
With myTable.Range.Find
.Text = "([^13]){2,}"
.Replacement.Text = "\1"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
For Each myCell In myTable.Range.Cells
Set myCellRng = myCell.Range
With myCellRng.Paragraphs
If .Count > 1 And Len(.Last.Range) = 2 Then
.Last.Previous.Range.Characters.Last.Delete
End If
End With
Next
Next
End Sub

复制代码

413191246se · 发表于 2018-5-21 17:37

m0018 朋友代码未做到位，请继续努力！

ming0018 · 发表于 2018-5-21 17:41

413191246se 发表于 2018-5-21 17:37
m0018 朋友代码未做到位，请继续努力！

请指教哪里没到位

duquancai · 发表于 2018-5-21 18:42

有时间，我写个到位的代码。有时间再写哈。

413191246se · 发表于 2018-5-21 18:53

如果某个段落上方还有一个回车符，你的代码就不能删除它，ming0018 朋友。

413191246se · 发表于 2018-5-21 18:55

请试试我的代码，就能删除表格中某个段落上方的空段。

Sub 表格处理()
Dim t As Table, c As Cell, i&, j&, k&, x&, y&, z&, e&, s As Paragraph, v&, u As Range, w&
For Each s In ActiveDocument.Paragraphs
If s.Range.Style = "正文" Then v = s.Range.Font.Size: Exit For
Next
If Selection.Information(wdWithInTable) = True Then i = 1
For Each t In ActiveDocument.Tables
If i = 1 Then Set t = Selection.Tables(1)
With t
With .Range
x = .Information(wdEndOfRangeRowNumber)
y = .Information(wdEndOfRangeColumnNumber)
z = .Cells.Count
End With
If x <> 1 Then
If z = x * y Then
For k = 1 To y
For j = 1 To x - 1
If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
If e = 0 Then Exit For
Next j
If e = 0 Then Exit For
Next k
Else
e = 0
End If
Else
e = 1
End If
With .Rows
.WrapAroundText = False
.Alignment = wdAlignRowLeft
.LeftIndent = CentimetersToPoints(0)
If e = 1 Then
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0.9)
End If
End With
If .LeftPadding <> CentimetersToPoints(0.19) Then .LeftPadding = CentimetersToPoints(0.19)
If .RightPadding <> CentimetersToPoints(0.19) Then .RightPadding = CentimetersToPoints(0.19)
With .Range
.Find.Execute "^l", , , 0, , , , , , "^p", 2
.Find.Execute "^13", , , 0, , , , , , "^p", 2
End With
.Select
Selection.MoveDown unit:=wdParagraph, Count:=1, Extend:=wdExtend
CommandBars.FindControl(ID:=122).Execute
CommandBars.FindControl(ID:=123).Execute
.Select
Selection.ClearFormatting
' If e = 1 Then .Range.Font.Color = wdColorBlue Else .Range.Font.Color = wdColorRed
With .Range
With .Font
If v = 16 Then
.Name = "仿宋"
.Name = "Times New Roman"
End If
.Size = 12
.Kerning = 0
.DisableCharacterSpaceGrid = True
End With
With .ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.FirstLineIndent = CentimetersToPoints(0)
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphCenter
.AutoAdjustRightIndent = False
.DisableLineHeightGrid = True
End With
.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
.AutoFitBehavior (wdAutoFitContent)
.AutoFitBehavior (wdAutoFitContent)
.Select
.AutoFitBehavior (wdAutoFitWindow)
.AutoFitBehavior (wdAutoFitWindow)
If e = 1 Then
If Len(.Cell(2, 1).Range) > 2 Then
With .Rows(1).Range.Font
.Name = "黑体"
.Name = "Times New Roman"
.Bold = True
' .Color = wdColorRed
End With
End If
End If
'表格空段删除
For Each c In .Range.Cells
w = c.Range.Paragraphs.Count
If w > 1 Then
Set u = ActiveDocument.Range(Start:=c.Range.Paragraphs(1).Range.Start, End:=c.Range.Paragraphs(w - 1).Range.End)
For Each s In u.Paragraphs
If Len(s.Range) = 1 Then s.Range.Delete
Next
If Len(c.Range.Paragraphs(c.Range.Paragraphs.Count).Range) = 2 Then
If c.Range.Paragraphs.Count > 1 Then c.Range.Paragraphs(c.Range.Paragraphs.Count - 1).Range.Characters.Last.Delete
End If
End If
Next
End With
If i = 1 Then Exit For
Next
End Sub

复制代码

天空飘过啥 · 发表于 2018-5-21 19:50

pureshadow 发表于 2018-5-21 14:48
查找^p^p，替换为^p，多替换几次。

行的最后一段是空值，你的这个方法是不起作用的。
你可以试一下

		自动登录	找回密码
密码			免费注册

[求助] 批量删除单无格空行

评分