求助大神如何在多页word文档中按需要数字生成独立新文档

413191246se

* 楼主，我重新构思了一下，改变了思路，具体是：以循环遍历每个表格（及上下各一段）设为区域 r，再将其上和其下的区域全部删除，再另存为，循环处理。请试用：

1. Sub test()
   
2.     Dim s$, p$, y$, a&, i&, r As Range
   
3.     y = ActiveDocument.FullName
   
4.     a = ActiveDocument.Tables.Count
   
5. 
   
6.     Do While a > 0
   
7.         i = i + 1
   
8.         If i = 9 Then ActiveDocument.Close savechanges:=wdDoNotSaveChanges: End
   
9.         ActiveDocument.Tables(i).Select
   
10.         Selection.MoveStart 4, -1
    
11.         Selection.MoveEnd 4, 1
    
12.         Set r = Selection.Range
    
13.         ActiveDocument.Range(Start:=0, End:=r.Start).Select
    
14.         If i <> 1 Then Selection.Delete
    
15.         ActiveDocument.Range(Start:=r.End, End:=ActiveDocument.Content.End).Select
    
16.         If i = a Then
    
17.             With r
    
18.                 .Select
    
19.                 .Characters.Last.InsertParagraphBefore
    
20.                 .Characters.Last.InsertParagraphBefore
    
21.             End With
    
22.             With Selection
    
23.                 .MoveRight
    
24.                 .MoveLeft
    
25.                 .MoveLeft
    
26.                 .InsertParagraphBefore
    
27.                 .EndKey 6, 1
    
28.                 .Delete
    
29.             End With
    
30.             GoTo en
    
31.         End If
    
32.         Selection.Delete
    
33.         r.Characters.Last.Delete
    
34. en:
    
35.         ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
    
36. 
    
37.         With ActiveDocument
    
38.             p = .Path & ""
    
39.             s = .Tables(1).Range.Cells(3).Range.Text
    
40.             s = Left(s, Len(s) - 2)
    
41.             .SaveAs FileName:=p & s
    
42.             .Close
    
43.         End With
    
44.         Documents.Open FileName:=y
    
45.     Loop
    
46. End Sub

复制代码

adlsn2123

413191246se 发表于 2018-12-28 15:06
* 楼主，我重新构思了一下，改变了思路，具体是：以循环遍历每个表格（及上下各一段）设为区域 r，再将其上 ...

万分感激大侠，正在摸索上一个代码，大侠这就换了个想法达成目的了。而且这次的代码要适用的多。感激，而且感觉这次的代码及想法又打开了一个新角度。如果能摸透了，对处理文档资料很有帮助。越发感觉书读少了。赶紧订个几本书补充一下知识。再次感谢@413191245se的大力支持。

adlsn2123

413191246se 发表于 2018-12-28 15:06
* 楼主，我重新构思了一下，改变了思路，具体是：以循环遍历每个表格（及上下各一段）设为区域 r，再将其上 ...

想给大侠发个消息都没权限。囧囧囧
  求个大侠的好友位

413191246se

没关系，楼主，有问题就及时上来问，我不是大侠，本坛大侠很多的，高手如云，我能帮忙就会帮忙的。

jiangxiaoyun

Sub testFormatTxt()
    Dim i As Long, Rng As Range, MyDoc As Document, s$, iPath$
    Application.DisplayAlerts = wdAlertsNone
    iPath = ActiveDocument.Path & "\"
    With Selection
        For i = 1 To .Information(wdNumberOfPagesInDocument) - 1
            .GoTo wdGoToPage, wdGoToAbsolute, i
            .Bookmarks("\page").Range.Select
            s = .Tables(1).Cell(2, 2).Range.Text '不动产单元号
            s = Left(s, Len(s) - 2)
            Set Rng = .Range
'            Rng.Copy
            Set MyDoc = Documents.Add
            With Application.Windows(MyDoc).Selection
'                .HomeKey Unit:=wdStory
                  .GoTo wdGoToPage, wdGoToAbsolute, 1
                .Range.FormattedText = Rng
'                 .PasteAndFormat (wdFormatOriginalFormatting)
                .PageSetup.TopMargin = CentimetersToPoints(0.75)
                MyDoc.SaveAs Filename:=iPath & s & ".docx" '保存文档名
                MyDoc.Close '关闭文档
            End With
        Next
    End With
End Sub

根据大神的代码改写。发觉另存为的文档表格中房屋状况的标题（行高有改变）
于是就做了页面设置。
对于Word，我是小白菜。都不知道啥来的。
除了这个方法，应该还可以使用section来分页的。

jiangxiaoyun