文档合并时页面错乱，对段落文字中的页码递进特征进行页码

aihuang97

一篇文档因为整理合并时，弄得页码错乱，现在文档已经统一做成一篇文档是一页这一特征了，现在需要重新进行排序。

(一)分析：1（书页号：z14-1）是递增的顺序（如书页号：z14-1,书页号：z14-2,书页号：z14-3,书页号：z14-5）但是原文档页码数可能会有跳数，就是这篇文档占了两页的（现在vba原因,已整理成一页）
2，（标准编号：WS3-B-2601-97）是递增的顺序（标准编号：WS3-B-2601-97,标准编号：WS3-B-2602-97  ,标准编号：WS3-B-2603-97），可能人为错误，原文档有缺失的编号和重复的编号
要求：
做成两个VBA
一VBA是，按页号或标准编号进行排序，把查到的内容所在的页面整页，剪贴到文档最后（这样就排序正确了）
二VBA是，把查找的内容，复制保存到一个新文档中。

aihuang97

文档显示如下

aihuang97

1,自作文件如下，出现问题，就是为了每个页码独立，我强行插入了一个分页符，现在就是需要判断，加入一个文档末尾的空白页删除
2,如果关键字有重复的，如何也把复制到文档末尾。Do Loop命令

Sub 宏2()
Application.EnableCancelKey = xlDisabled
    Dim myRange '定义查找到的内容
    Dim myCos As Integer '定义显示框值
    Dim PageCount1 As Integer '文档总页数
    Dim PageCount2 As Integer '随机文档总页数
    Dim StartRange As Long, EndRange As Long, Fn As String, MyDoc As Document
    On Error Resume Next
    Dim GuangbianWeizhi As Long
    Dim ChazhaoNeirong
    Dim p, i
   PageCount1 = Selection.Information(wdNumberOfPagesInDocument) '读取文档总页数，做循环使用
   ' PageCount = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
     ChazhaoNeirong = InputBox("1请输入关键字序列", "请输入", "")
             If VBA.IsNumeric(ChazhaoNeirong) Then   '-1判断输入值是否为数字，是的话，执行下面
                    For i = 1 To PageCount1 '设置循环次数
                                        MsgBox "设置循环次." & PageCount1 & "警告..."
                        Selection.Find.ClearFormatting
                           With Selection.Find
                              .ClearFormatting
                              .text = ChazhaoNeirong
                              .Replacement.text = ""
                              .Forward = False
                              .Wrap = wdFindAsk
                              .Format = False
                              .MatchCase = False
                              .MatchWholeWord = True
                              .MatchByte = True
                              .MatchWildcards = False
                              .MatchSoundsLike = False
                              .MatchAllWordForms = False
                           End With
                               Selection.Find.Execute
                               If Selection.Find.Found = True Then
                                    GuangbianWeizhi = Selection.Information(wdActiveEndPageNumber) '查找到的字符位置页
                                    PageCount2 = Selection.Information(wdNumberOfPagesInDocument) '读取文档随机总页数，判断查找内容是否已在最后一页
                                   '      If GuangbianWeizhi < PageCount2 Then '判断查找内容是否是在最后一页，
                                              Dim rngStart As Range, rngEnd As Range
                                              Selection.GoTo 1, 1, GuangbianWeizhi
                                              Set rngStart = Selection.Range
                                              Set rngEnd = Selection.GoToNext(1)
                                              ActiveDocument.Range(rngStart.Start, rngEnd.Start).Select
                                              Selection.Cut
                                              Selection.EndKey Unit:=wdStory
                                              Selection.EndKey Unit:=wdStory
                                              Selection.InsertBreak Type:=wdPageBreak
                                              Selection.Paste
                                  '       Else
                                  '       End If
                                             ChazhaoNeirong = ChazhaoNeirong + 1 '查找内容数字+1
                                            
                               End If
                      Next
                     
                   '删除空白页
                     Selection.Find.ClearFormatting
                     Selection.Find.Replacement.ClearFormatting
                     With Selection.Find
                         .text = "^p^m^p^m"
                         .Replacement.text = "^m"
                         .Forward = False
                         .Wrap = wdFindAsk
                         .Format = False
                         .MatchCase = False
                         .MatchWholeWord = False
                         .MatchByte = True
                         .MatchWildcards = False
                         .MatchSoundsLike = False
                         .MatchAllWordForms = False
                     End With
                          Selection.Find.Execute Replace:=wdReplaceAll
                     
                Else '-1判断输入值是否为数字，不是的话，执行下面
                    MsgBox "必须输入数字.", "警告..."
                    Exit Sub '如果不是数字，退出程序
                End If

aihuang97

我的这个有些问题，就是有时候会出现大的跳数。哪个大神帮助修改下？

sylun

可试试如下代码（仅针对附件文档）：

1. Sub test()
   
2.     Dim i%, j%, n%, d, temp, data$(), info$()
   
3.     Dim myDoc As Document, newDoc As Document
   
4.    
   
5.     Set d = CreateObject("Scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     Set myDoc = ActiveDocument
   
8.     With myDoc.Content.Find
   
9.         .Style = "标题"
   
10.         Do While .Execute
    
11.             ReDim Preserve data(5, i)
    
12.             temp = Split(.Parent.Next(4, 2).Text, "：")
    
13.             data(0, i) = i + 1
    
14.             data(1, i) = Replace(.Parent.Text, Chr(13), "")
    
15.             data(2, i) = Replace(temp(1), "标准编号", "")
    
16.             data(3, i) = Replace(temp(2), Chr(13), "")
    
17.             data(4, i) = .Parent.Information(3)
    
18.             j = InStrRev(data(2, i), "-")
    
19.             data(5, i) = Left(data(2, i), j) & Format(Mid(data(2, i), j + 1), "000")
    
20.             If d.Exists(data(3, i)) = False Then
    
21.                 d(data(3, i)) = d(data(3, i)) + 1
    
22.             Else
    
23.                 ReDim Preserve info(n)
    
24.                 info(n) = n + 1 & Chr(9) & data(3, i) & Chr(9) _
    
25.                     & data(1, i) & Chr(9) & data(2, i) & Chr(9) & data(4, i)
    
26.                 n = n + 1
    
27.             End If
    
28.             i = i + 1
    
29.         Loop
    
30.     End With
    
31.     WordBasic.sortarray data, 0, 0, i - 1, 1, 5
    
32.     Set newDoc = Documents.Add(myDoc.FullName)
    
33.     newDoc.Content.Delete
    
34.     With myDoc
    
35.         For i = 0 To UBound(data, 2)
    
36.             .GoTo(1, 1, data(4, i)).Select
    
37.             Do While Selection.Style <> "标题"
    
38.                 Selection.MoveDown 4
    
39.             Loop
    
40.             newDoc.Bookmarks("\endofdoc").Range.FormattedText = .Bookmarks("\headinglevel").Range.FormattedText
    
41.         Next
    
42.     End With
    
43.     With newDoc.Content
    
44.         .Parent.Styles("标题").ParagraphFormat.PageBreakBefore = True
    
45.         .Find.Execute findtext:="^m", replacewith:="", Replace:=2
    
46.         If n > 0 Then .InsertAfter Chr(13) & "重复的标准编号：" & Chr(13) & Join(info, Chr(13))
    
47.     End With
    
48.     ReDim info(i - 1)
    
49.     For i = 0 To UBound(data, 2)
    
50.         info(i) = info(i) & i + 1 & vbTab & data(1, i) & Chr(9) & data(2, i) & Chr(9) _
    
51.             & data(3, i) & Chr(9) & data(4, i)
    
52.     Next i
    
53.     With Documents.Add.Content.ParagraphFormat
    
54.         .Parent.Text = "查找结果" & Chr(13) & Join(info, Chr(13))
    
55.         .TabStops.Add 40
    
56.         .TabStops.Add 190
    
57.         .TabStops.Add 260
    
58.         .TabStops.Add 400
    
59.     End With
    
60.     Application.ScreenUpdating = True
    
61. End Sub

复制代码

413191246se

sylun 兄：过年好！（最近，心烦意乱，什么代码也没写出来，有时玩玩游戏 DOOM 3 ）