求教：如何用VBA来删除两个表中间的空白段

ddddddddd

各位老师：

我想请教一个问题，关于如何将两个表中间的空白段删除，但不能改变横，纵版式。我参照守老师写了一个代码，

但它把都按纵向排版了，请赐教　。

Sub DelBlank() Dim i As Paragraph, n As Long Dim parcount As Integer Application.ScreenUpdating = False '关闭屏幕刷新 parcount = ActiveDocument.Paragraphs.Count For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环 If Len(i.Range) = 1 Then '判断段落长段,此处可根据文档实际情况 n = n + 1 '计数 If n > 7 And n < parcount - 7 Then i.Range.Delete '进行必要的修改可将任意长度段落删除 End If End If Next MsgBox "共删除空白段落" & n & "个!" Application.ScreenUpdating = True '恢复屏幕刷新 End Sub

ddddddddd

YlVIfq9C.rar (6.5 KB, 下载次数: 21)

2005-4-13 10:32 上传

点击文件名下载附件
求教：如何用VBA来删除两个表中间的空白段

这是复制的文件，请帮忙看一下，谢谢

守柔

请参:

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-4-14 4:43:35 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub ExampleForDelBlank() Dim i As Paragraph, MyRange As Range, N As Integer On Error Resume Next '忽略错误(此处必需) Application.ScreenUpdating = False '关闭屏幕更新 With ActiveDocument For Each i In .Paragraphs '在活动文档的段落集合中循环 If Len(i.Range) = 1 Then '如果为空白段落 '定义一个RANGE对象 Set MyRange = .Range(i.Range.Start, i.Range.Next(1).Start + 1) '如果在该RANGE中没有发现分节符或者分页符 If MyRange.Find.Execute(findtext:="^b") = False And MyRange.Find.Execute(findtext:="^m") = False Then i.Range.Delete '删除该段落 N = N + 1 '计数 End If End If Next MsgBox "WORD 共删除了" & N & "个空白段落", vbOKOnly + vbInformation End With Application.ScreenUpdating = True '恢复屏幕更新 End Sub '----------------------

ddddddddd

谢谢守老师的指教，可能是我没有说明白吧，我的原意是想只把两个表格中间的空白段删除，其它部位的空白段不变，我运行了您的代码，它能把两表中间的空白段删除，但同时也其它部位（比如：第一张表前，第一张表后）的空白段也删除了，请问能只删除指定两表中间的空白段吗？谢谢指点！！

守柔

其实你参照也一下，就通了。可惜了！

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-4-15 4:05:57 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub ExampleForDelBlank() Dim i As Paragraph, MyRange As Range, N As Integer, SelRange As Range On Error Resume Next '忽略错误(此处必需) If Selection.Type = wdSelectionIP Then MsgBox "您必须选定需要进行删除操作的区域!", _ vbOKOnly + vbInformation: Exit Sub '如果未选定区域则友情提示并退出程序运行 Set SelRange = Selection.Range '定义一个RANGE区域为选定区域 ' With ActiveDocument '此处作为示例,定义一个RANGE区域为表1的开始到表2的结束 ' Set SelRange = .Range(.Tables(1).Range.Start, .Tables(2).Range.End) ' End With Application.ScreenUpdating = False '关闭屏幕更新 With SelRange For Each i In .Paragraphs '在活动文档的段落集合中循环 If Len(i.Range) = 1 Then '如果为空白段落 '定义一个RANGE对象 Set MyRange = ActiveDocument.Range(i.Range.Start, i.Range.Next(1).Start + 1) '如果在该RANGE中没有发现分节符或者分页符 If MyRange.Find.Execute(findtext:="^b") = False And MyRange.Find.Execute(findtext:="^m") = False Then i.Range.Delete '删除该段落 N = N + 1 '计数 End If End If Next MsgBox "WORD 共删除了" & N & "个空白段落", vbOKOnly + vbInformation End With Application.ScreenUpdating = True '恢复屏幕更新 End Sub '----------------------

ddddddddd

谢谢守老师的指指点。非常 感谢!!