vba识别空白页并删除

xipick

求助版主及论坛上的各位高人，如何识别出一个word中的所有空白页，并删除之。这些空白页有可能是因为加了分页符而出现的，有可能是一些空格或是回车符而导致的，也有可能是表格后面，紧跟着的空白页。并且这些空白页是分散在整个word文档中的。求助版主及各位高手，看看有什么方法删除之啊

sqhsqhli

这个问题好，我也想知道

413191246se

    这个问题提得好！我也赞成。——刚才在 WORD 中试了一会儿，解决思路如下：
    守柔版主 有一段代码，叫“选定当前页文本”，任何一篇文档，经我的“删除段首空格”和“删除空行”两个宏处理后，如果它是空白页，将只剩下一个回车符，仅仅一个！那么，对这页“选定当前页文本”，它的字长是 len(selection.text)=1，是 1 就说明这页就仅剩下一个回车符！
    至于怎么删除这个回车符，要看前面一页，或整个文档，有几节（分节符），是否是分页符，……具体以后再说。

sqhsqhli

我想空白页的产生应该有许多种情况，写个删除的宏代码应该包括以下部分。1、删除分页符后的不含字符的空白页。2、删除表格后产生的空白页（这个往往不是删除可以解决的）。3、删除各种特殊字符形成的空白页。
针对第3点，我认为：
楼上的“删除段首空格”和“删除空行”仅仅删除4种字符，太少了，不够完善（比如点插入---符号---特殊字符---1/4长划线，将其置于段首，就不能删除）。我想本身也不应该这样一概删除，假如文章开始某页特地留一空行，删除后所有页面都将重排，这样就不是我们所希望的那样删除整页了。  如果我的想法是对的，不如反过来做——逐页选定，如果页面中出现了特殊字符以外的字符则保留，否则删除。

xipick

sqhsqhli 发表于 2011-12-20 20:53
我想空白页的产生应该有许多种情况，写个删除的宏代码应该包括以下部分。1、删除分页符后的不含字符的空白页 ...

其实吧，就算是手动删除空白页，有时候都删不掉，估计用vba更是难上加难了啊。

ltz888

问题提得好！赞成

yyyydddd8888

等待更完美的方法！

ycpi

我等待，excel如何选择空白页。例如前n也都有内容，但n+1页是空白页，如何用vba选中。高人指点啊…………………………

646411527

我也遇到了同样的问题，下面代码把文档按两页拆分另存为新文档没问题，按一页拆分就会提示“ .LeftMargin = sinLeft”有问题，超出范围还是什么。

Sub SplitEveryFivePagesAsDocuments()
    Dim oSrcDoc As Document, oNewDoc As Document
    Dim strSrcName As String, strNewName As String, strNewDot As String
    Dim oRange As Range
    Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
    Dim fso As Object
    Dim sinLeft As Single, sinRight As Single, sinTop As Single, sinBottom As Single
    Dim i As Integer, N As Integer
    Dim pgOrientation As WdOrientation

    Application.ScreenUpdating = False    '关闭屏幕更新

    Const nSteps = 2        ' 修改这里控制每隔几页分割一次

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    Set oRange = oSrcDoc.Content

    nTotalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
    oRange.Collapse wdCollapseStart
    oRange.Select
    For nIndex = 1 To nTotalPages Step nSteps
        Set oNewDoc = Documents.Add
        If nIndex + nSteps > nTotalPages Then
            nBound = nTotalPages
        Else
            nBound = nIndex + nSteps - 1
        End If
        For nSubIndex = nIndex To nBound
            oSrcDoc.Activate
            oSrcDoc.Bookmarks("\page").Range.Copy
            '读取页面设置
            With oSrcDoc.Bookmarks("\page").Range.Sections(1).PageSetup
                sinLeft = .LeftMargin    '左页边距
                sinRight = .RightMargin    '右页边距
                sinTop = .TopMargin    '上边距
                sinBottom = .BottomMargin    '下边距
                pgOrientation = .Orientation    '纸张方向
            End With
            oSrcDoc.Windows(1).Activate
            Application.Browser.Target = wdBrowsePage
            Application.Browser.Next

            oNewDoc.Activate
            oNewDoc.Windows(1).Selection.Paste
            oNewDoc.Background.Fill.Transparency = oSrcDoc.Background.Fill.Transparency
            oNewDoc.Background.Fill.PresetTextured msoTexturePinkTissuePaper
            With oNewDoc.PageSetup
                .Orientation = pgOrientation
                .LeftMargin = sinLeft
                .RightMargin = sinRight
                .TopMargin = sinTop
                .BottomMargin = sinBottom
            End With
        Next nSubIndex
        '删除空白段落
        N = 0
        temp = ActiveDocument.Paragraphs.Count
        For i = temp To 1 Step -1
            If Len(Trim(ActiveDocument.Paragraphs(i).Range)) = 1 Then
                ActiveDocument.Paragraphs(i).Range.Delete
                N = N + 1
            Else
                Exit For
            End If
        Next

        strSrcName = oSrcDoc.FullName
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                                   fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps) & "." & fso.GetExtensionName(strSrcName))
        oNewDoc.SaveAs strNewName
        oNewDoc.Close False
    Next nIndex
    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True    '恢复屏幕更新
    MsgBox "结束！"

End Sub

下面这段代码按一页拆分后面就会有一页空白页而且删不掉。

Sub SplitEveryFivePagesAsDocuments()
    Dim oSrcDoc As Document, oNewDoc As Document
    Dim strSrcName As String, strNewName As String
    Dim oRange As Range
    Dim nIndex As Integer, nSubIndex As Integer, nTotalPages As Integer, nBound As Integer
    Dim fso As Object


    Const nSteps = 1        ' 修改这里控制每隔几页分割一次

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oSrcDoc = ActiveDocument
    Set oRange = oSrcDoc.Content

    nTotalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
    oRange.Collapse wdCollapseStart
    oRange.Select
    For nIndex = 1 To nTotalPages Step nSteps
        Set oNewDoc = Documents.Add
        If nIndex + nSteps > nTotalPages Then
            nBound = nTotalPages
        Else
            nBound = nIndex + nSteps - 1
        End If
        For nSubIndex = nIndex To nBound
            oSrcDoc.Activate
            oSrcDoc.Bookmarks("\page").Range.Copy
            oSrcDoc.Windows(1).Activate
            Application.Browser.Target = wdBrowsePage
            Application.Browser.Next

            oNewDoc.Activate
            oNewDoc.Background.Fill.Transparency = 0#
            oNewDoc.Background.Fill.PresetTextured msoTexturePinkTissuePaper
            oNewDoc.Windows(1).Selection.Paste
        Next nSubIndex
        strSrcName = oSrcDoc.FullName
        strNewName = fso.BuildPath(fso.GetParentFolderName(strSrcName), _
                                   fso.GetBaseName(strSrcName) & "_" & (nIndex \ nSteps + 1) & "." & fso.GetExtensionName(strSrcName))
        oNewDoc.SaveAs strNewName
        oNewDoc.Close False
    Next nIndex
    Set oNewDoc = Nothing
    Set oRange = Nothing
    Set oSrcDoc = Nothing
    Set fso = Nothing


    MsgBox "结束！"

End Sub