VBA删除空页5941错误代码

yjwdjfqb

VBA删除空页5941错误代码
请高手老师帮帮看看，是什么问题，谢谢大家了！
代码如下：（代码由论坛老师提供）

Sub 检查和删除WORD文档末空白页()
    Dim IsDelete As Boolean
    Dim PageCount As Long
    Dim rRange As Range
    Dim iInt As Integer, DelCount As Integer
    Dim tmpstr As String
    IsDelete = True
    PageCount = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
    For iInt = 1 To PageCount
        '超过PageCount退出
        If iInt > PageCount Then Exit For
        '取每一页的内容
        If iInt = PageCount Then
            Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt).Start)
        Else
            Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt).Start, End:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt + 1).Start)
        End If
        If Replace(rRange.Text, Chr(13), "") = "" Or Replace(rRange.Text, Chr(13), "") = Chr(12) Then
            'tmpstr = tmpstr & "第 " & iInt & " 页是空页" & vbCrLf
            tmpstr = "第 " & iInt & " 页后是空页"
            '删除
            If IsDelete Then
                DelCount = DelCount + 1
                '删除空白页
                rRange.Text = Replace(rRange.Text, Chr(13), "")
                rRange.Text = ""
                '重算页数
                PageCount = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
                If iInt <> PageCount Then
                    '页删除后，页码变化，重新检查当前页
                    iInt = iInt - 1
                Else
                    '最后一个空页
                    Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, PageCount - 1).Start, End:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, PageCount + 1).Start)
                    '如果是分页符,删除上一页中的换页符
                    If InStr(1, rRange.Text, Chr(12)) > 0 Then
                        rRange.Characters(InStr(1, rRange.Text, Chr(12))) = ""
                    Else
                        '没有分页符,通过选中后删除,最好不这样做，如果判断错误，有误删除的风险
                        Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt).Start)
                        rRange.Select
                        Selection.Delete
                    End If
                    Exit For
                End If
            End If
        End If
    Next
    If 1 = 1 Or Not IsDelete Then
        If tmpstr = "" Then
            MsgBox "没有空页", vbInformation + vbOKOnly
        Else
            MsgBox tmpstr, vbInformation + vbOKOnly
        End If
    Else
        If DelCount > 0 Then MsgBox "删除空页 " & DelCount, vbInformation + vbOKOnly
    End If
End Sub

VBA删除空页5941错误代码.rar (13.25 KB, 下载次数: 17)

2015-9-3 10:03 上传

点击文件名下载附件

yjwdjfqb

请高手老师帮帮忙，谢谢大家了！

yjwdjfqb

请老师们帮帮忙，谢谢大家了！

zhanglei1371

Debug.Print rRange.Characters.Count，得到的字符数只有24个。分页符的位置是32。characters并不能包含所有的字符。
表格自身也是字符，但是这个字符却不在characters中。故实际的位置比characters多了8个。可以使用替换的方式解决：

1. Sub 检查和删除WORD文档末空白页()
   
2.     Dim IsDelete As Boolean
   
3.     Dim PageCount As Long
   
4.     Dim rRange As Range
   
5.     Dim iInt As Integer, DelCount As Integer
   
6.     Dim tmpstr As String
   
7. 
   
8.     IsDelete = True
   
9.     PageCount = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
   
10.     For iInt = 1 To PageCount
    
11.         '超过PageCount退出
    
12.         If iInt > PageCount Then Exit For
    
13. 
    
14.         '取每一页的内容
    
15.         If iInt = PageCount Then
    
16.             Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt).Start)
    
17.         Else
    
18.             Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt).Start, End:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt + 1).Start)
    
19.         End If
    
20. 
    
21.         If Replace(rRange.Text, Chr(13), "") = "" Or Replace(rRange.Text, Chr(13), "") = Chr(12) Then
    
22.             'tmpstr = tmpstr & "第 " & iInt & " 页是空页" & vbCrLf
    
23.             tmpstr = "第 " & iInt & " 页后是空页"
    
24.             '删除
    
25.             If IsDelete Then
    
26.                 DelCount = DelCount + 1
    
27.                 '删除空白页
    
28.                 rRange.Text = Replace(rRange.Text, Chr(13), "")
    
29.                 rRange.Text = ""
    
30.                 '重算页数
    
31.                 PageCount = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
    
32.                 If iInt <> PageCount Then
    
33.                     '页删除后，页码变化，重新检查当前页
    
34.                     iInt = iInt - 1
    
35.                 Else
    
36.                     '最后一个空页
    
37.                     Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, PageCount - 1).Start, End:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, PageCount + 1).Start)
    
38.                     '如果是分页符,删除上一页中的换页符
    
39.                     If InStr(1, rRange.Text, Chr(12)) > 0 Then
    
40.                         rRange.Find.Execute findtext:=Chr(12), MatchWildcards:=1, replacewith:="", Replace:=2
    
41.                     Else
    
42.                         '没有分页符,通过选中后删除,最好不这样做，如果判断错误，有误删除的风险
    
43.                         Set rRange = ActiveDocument.Range(Start:=ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, iInt).Start)
    
44.                         rRange.Select
    
45.                         Selection.Delete
    
46.                     End If
    
47.                     Exit For
    
48.                 End If
    
49.             End If
    
50.         End If
    
51.     Next
    
52. 
    
53.     If 1 = 1 Or Not IsDelete Then
    
54.         If tmpstr = "" Then
    
55.             MsgBox "没有空页", vbInformation + vbOKOnly
    
56.         Else
    
57.             MsgBox tmpstr, vbInformation + vbOKOnly
    
58.         End If
    
59.     Else
    
60.         If DelCount > 0 Then MsgBox "删除空页 " & DelCount, vbInformation + vbOKOnly
    
61.     End If
    
62. End Sub

复制代码

yjwdjfqb

zhanglei1371 发表于 2015-9-3 18:46
Debug.Print rRange.Characters.Count，得到的字符数只有24个。分页符的位置是32。characters并不能包含所 ...

老师你好，感谢你的帮助，我测试了下

像下面这个文件，其中，第一页有内容、第二页没有内容、第三页有内容

正常情况下执行代码，应该是删除第二页，保留第一页和第三页内容
但，执行代码后，只有第一页了，请老师斧正下，谢谢了！
测试.rar (3.32 KB, 下载次数: 17)

2015-9-3 20:11 上传

点击文件名下载附件

zhanglei1371

原来你不懂这些东西阿。早知道就不去那么费劲给你解释了。
既然是简单的问题，就用简单的方法：
Sub sdf()
    Selection.HomeKey wdStory
    For i = 1 To ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
        sr = Selection.Bookmarks("\page").Range.Text
        For Each m In Array(Chr(13), Chr(12), " ", Chr(9))      ‘这里可添加空白页的空白字符
            sr = Replace(sr, m, "")
        Next
        If Len(sr) = 0 Then Selection.Bookmarks("\page").Range.Delete
        Application.Browser.Next
    Next
End Sub
多运行几次，就OK了。

yjwdjfqb

zhanglei1371 发表于 2015-9-4 08:58
原来你不懂这些东西阿。早知道就不去那么费劲给你解释了。
既然是简单的问题，就用简单的方法：
Sub sdf( ...

感谢老师的帮助

4楼的代码，能删除有表格的WORD文档中的空白页。但会出来五楼的情况

6楼的代码，能删除五楼的附件，却删除不了有表格的WORD文档中的空白页。

想用一个代码，即能满足一楼的需要，也能满足五楼的需要

麻烦老师了，非常的感谢！