手工提取目录，如何反向遍历段落在标题后插入页码并提取后插入文末

小声说话666

不使用标题，想用手工提取目录。 多篇文章的汇编大标题统一为二号黑体，想通过遍历段落的方法在标题后插入制表符和页码，然后提取内容到文章后手工制作目录。

（以下代码在WPS2016中测试 可以在标题下一行插入制表符和当前光标所在页码。不能插入标题所在码页。WORD2007中假死)

Sub 遍历段落插入页码()

     Dim oP As Paragraph
     Dim P
     P = Selection.Information(wdActiveEndPageNumber)
     For Each oP In ActiveDocument.Paragraphs
         If oP.Range.Font.Name = "黑体" And Len(oP.Range) > 1 Then oP.Range.InsertAfter vbTab & P & vbCr
     Next
End Sub

还有如何倒着遍历段落还望指点。

413191246se

请 楼主 将最后面提取目录后的第 2 页缩小字符间距，以使制表符充满一行。

1. Sub aaaa_LoopPara_GetTitle()
   
2.     Dim j As Long, s As String, n&
   
3.     With ActiveDocument
   
4.         '倒序循环遍历所有段落
   
5.         For j = .Paragraphs.Count To 1 Step -1
   
6.             With .Paragraphs(j).Range
   
7.                 .Font.ColorIndex = wdRed
   
8.                 If .Font.NameFarEast = "黑体" Then
   
9.                     If Len(.Text) > 1 Then
   
10.                         .Characters.Last.InsertBefore Text:=vbTab & .Information(wdActiveEndPageNumber)
    
11.                     End If
    
12.                 End If
    
13.             End With
    
14.         Next
    
15.         
    
16.         '循环遍历所有段落
    
17.         Dim i As Paragraph
    
18.         For Each i In .Paragraphs
    
19.             If i.Range Like "*" & vbTab & "[0-9]" & vbCr Or i.Range Like "*" & vbTab & "[0-9][0-9]" & vbCr Then
    
20.                 i.Range.Font.ColorIndex = wdBlue
    
21.                 s = s & i.Range
    
22.                 n = n + 1
    
23.             End If
    
24.         Next
    
25. 
    
26.         .Content.InsertAfter Text:=vbCr & "*********************" & vbCr & "目录" & vbCr & s
    
27.         .Characters.Last.Delete
    
28.         
    
29.         .Range(Start:=.Paragraphs(.Paragraphs.Count - n + 1).Range.Start, _
    
30.             End:=.Content.End).Select
    
31.             
    
32.         With Selection
    
33.             .Font.ColorIndex = wdBlue
    
34.             .MoveStart 4, -1
    
35.             
    
36.             '取消首行缩进
    
37.             With .ParagraphFormat
    
38.                 .CharacterUnitFirstLineIndent = 0
    
39.                 .FirstLineIndent = CentimetersToPoints(0)
    
40.             End With
    
41.             
    
42.             With .Paragraphs(1).Range
    
43.                 With .ParagraphFormat
    
44.                     .SpaceBefore = 12
    
45.                     .SpaceAfter = 12
    
46.                     .Alignment = wdAlignParagraphCenter
    
47.                 End With
    
48.                 .Characters(1).InsertAfter Text:=Space(4)
    
49.             End With
    
50.             
    
51.             '制表位
    
52.             .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(15.04) _
    
53.                 , Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderDots
    
54.         End With
    
55.     End With
    
56. End Sub

复制代码

小声说话666

真是没有大神不能解决的问题. 歪瑞古德!    多谢，多谢。