存在 word 文档另存为 wps 时，出现页码变多，与 word 中的不一致的情况。对于其中的某页标题行前有空行，空行内包含分页符与前面的文字在同一段落。需要删除改分页符，同时使原标题段落格式（大纲级别，编号，下划线等）不变，还要使其不上提到前一页。
Rem Attribute VB_Name = "ProcessSelectedParagraphs"
Sub ProcessSelectedParagraphs()
'
' 终极版：处理选定段落的分页符、空行及标题排版
' 1. 智能处理标题前的分页符/换行符 (保护标题样式，防止误删段落标记)
' 2. 自动删除完全空白的页面
' 3. 替换段落内部分页符
'Dim para As ParagraphDim i As LongDim deletedCount As LongDim pageBreaksReplaced As LongDim emptyPagesDeleted As LongDim report As StringDim undoRecord As undoRecorddeletedCount = 0pageBreaksReplaced = 0emptyPagesDeleted = 0report = "处理结果报告:" & vbCrLf & vbCrLf' 创建撤销记录Set undoRecord = Application.undoRecordundoRecord.StartCustomRecord "智能排版处理"Application.ScreenUpdating = False' ==========================================================================================' 第一步：倒序遍历，处理分页符替换和标题规则' ==========================================================================================For i = Selection.Paragraphs.Count To 1 Step -1Set para = Selection.Paragraphs(i)Dim paraText As StringparaText = para.Range.text' --- 规则 A: 标题行处理 ---' 如果是标题行 (大纲级别 1-9)If IsHeading(para) ThenDim prevPara As ParagraphSet prevPara = para.PreviousIf Not prevPara Is Nothing ThenDim prevRng As RangeSet prevRng = prevPara.RangeDim prevText As StringprevText = prevRng.text' 检查前一段是否包含分页符Dim hasPageBreak As BooleanhasPageBreak = (InStr(prevText, Chr(12)) > 0)' 情况1: 前一段是纯粹的分页符/空行 (例如只有 ^m^p 或 ^p)If IsJustBreak(prevText) Then' 再次确认不是图片If prevRng.InlineShapes.Count = 0 And prevRng.ShapeRange.Count = 0 ThenprevRng.DeletedeletedCount = deletedCount + 1' 【关键修正】如果删除了分页符，为了保持标题在页首，' 将标题段落设置为"段前分页"If hasPageBreak Thenpara.Format.PageBreakBefore = TrueEnd IfEnd If' 情况2: 前一段包含文本，但末尾有分页符 (Text...^m^p)' 策略：只删除分页符(^m)，保留段落标记(^p)，同时设置标题段前分页ElseIf hasPageBreak ThenWith prevRng.Find.ClearFormatting.text = "^m".Replacement.text = "" ' 仅移除分页符.Forward = True.Wrap = wdFindStop.Execute Replace:=wdReplaceAllEnd With' 【关键修正】显式分页符转为样式分页para.Format.PageBreakBefore = TrueEnd IfEnd IfEnd If' --- 规则 B: 替换段落内部的分页符 (非标题前的情况) ---' 如果段落文本中包含分页符 (Chr(12))' 注意：如果上面规则A已经处理了该段（作为某标题的前一段），这里可能会重复处理？' 由于是倒序，当前 para 是 i。规则A处理的是 i-1。' 所以当前 para (i) 如果含有分页符，说明它不是作为标题前缀被处理的（或者它本身就是标题但含有分页符）If InStr(para.Range.text, Chr(12)) > 0 ThenDim replaced As Longreplaced = ReplacePageBreaksAdvanced(para.Range.Duplicate)If replaced > 0 ThenpageBreaksReplaced = pageBreaksReplaced + replacedEnd IfEnd IfNext i' ==========================================================================================' 第二步：检测并删除空页 (全页为空行或不可见字符)' ==========================================================================================Dim searchRange As RangeSet searchRange = Selection.RangeIf Selection.Paragraphs.Count > 0 ThensearchRange.Start = Selection.Paragraphs(1).Range.StartsearchRange.End = Selection.Paragraphs(Selection.Paragraphs.Count).Range.EndEnd IfDim pBreak As RangeSet pBreak = searchRange.DuplicateWith pBreak.Find.ClearFormatting.text = "^m".Forward = True.Wrap = wdFindStopDo While .ExecuteDim checkRange As RangeSet checkRange = pBreak.DuplicatecheckRange.Collapse wdCollapseEndDim nextBreakFinder As RangeSet nextBreakFinder = searchRange.Document.Range(checkRange.Start, searchRange.End)Dim endOfPage As LongIf nextBreakFinder.Find.Execute(FindText:="^m", Forward:=True, Wrap:=wdFindStop) ThenendOfPage = nextBreakFinder.StartElseendOfPage = searchRange.EndEnd IfcheckRange.End = endOfPageIf IsRangeEmpty(checkRange) ThenIf checkRange.InlineShapes.Count = 0 And checkRange.ShapeRange.Count = 0 ThenDim deleteRange As RangeSet deleteRange = searchRange.Document.Range(pBreak.Start, checkRange.End)deleteRange.DeleteemptyPagesDeleted = emptyPagesDeleted + 1End IfEnd IfpBreak.Collapse wdCollapseEndIf pBreak.Start >= searchRange.End Then Exit DoLoopEnd WithApplication.ScreenUpdating = TrueundoRecord.EndCustomRecordreport = report & "替换分页符: " & pageBreaksReplaced & vbCrLfreport = report & "清理标题前分隔符: " & deletedCount & vbCrLfreport = report & "删除空页: " & emptyPagesDeleted & vbCrLfMsgBox report, vbInformation, "处理完成"
End Sub' ==========================================================================================
' 辅助函数
' ==========================================================================================Function IsHeading(para As Paragraph) As BooleanIsHeading = (para.OutlineLevel >= wdOutlineLevel1 And para.OutlineLevel <= wdOutlineLevel9)
End FunctionFunction IsJustBreak(text As String) As Boolean' 检查文本是否只包含 分页符、换行符、空白Dim temp As Stringtemp = texttemp = Replace(temp, Chr(13), "")temp = Replace(temp, Chr(12), "")temp = Replace(temp, Chr(11), "")temp = Replace(temp, " ", "")temp = Replace(temp, vbTab, "")temp = Replace(temp, ChrW(12288), "")temp = Replace(temp, Chr(160), "")IsJustBreak = (Len(temp) = 0)
End FunctionFunction IsRangeEmpty(rng As Range) As BooleanDim txt As Stringtxt = rng.textIf Len(txt) > 5000 ThenIsRangeEmpty = FalseExit FunctionEnd Iftxt = Replace(txt, Chr(13), "")txt = Replace(txt, Chr(11), "")txt = Replace(txt, Chr(12), "")txt = Replace(txt, " ", "")txt = Replace(txt, vbTab, "")txt = Replace(txt, ChrW(12288), "")txt = Replace(txt, Chr(160), "")IsRangeEmpty = (Len(txt) = 0)
End FunctionFunction ReplacePageBreaksAdvanced(rng As Range) As LongDim replaceCount As LongDim findRange As RangereplaceCount = 0If InStr(rng.text, Chr(12)) = 0 ThenReplacePageBreaksAdvanced = 0Exit FunctionEnd IfSet findRange = rng.DuplicateWith findRange.Find.ClearFormatting.text = "^m".Replacement.text = "^p".Forward = True.Wrap = wdFindStop.Format = False.MatchWildcards = FalseDo While .Execute(Replace:=wdReplaceOne)replaceCount = replaceCount + 1findRange.Collapse wdCollapseEndIf findRange.Start >= rng.End Then Exit DoLoopEnd WithReplacePageBreaksAdvanced = replaceCount
End Function
