如何获取Word VBA中标题1之后的列表？

Question

一个很长的文件的下面显示模式：

<heading1> 
<numberedlist> 
<heading2> 
<numberedlist> 
<heading3> 
<numberedlist> 

当我使用Document.Lists我得到的文档中的所有列表。当使用迭代哪里Document.Paragraphs我Document.Paragraphs(i).Style = "Heading 1"得到所有的标题。

但我想是List（不在名单的段落），并立即开始“标题1”

Answer 1

假设您的文档可以看起来像一个下面的图片后：

使用这个提议代码，你可以选择第一个列表（抽穗后立即）和位于下方航向其他类似的列表，但不是第二个（这里有关于这种情况的航向和列表 - 之间的附加段看到里面的代码补充意见）。

Sub List_after_Heading() 

    Dim rngLIST As Range 
    Set rngLIST = ActiveDocument.Content 

    With rngLIST.Find 
     .Style = "Heading 1" '<--change into your Heading name 
     .Forward = True 
     .Wrap = wdFindStop 
    End With 

    Do 
     rngLIST.Find.Execute 
     If rngLIST.Find.Found Then 

      'I assume that list start in NEXT paragraph, if not, it wouldn't be found 
      'or you need to change part of line into .Next.Next paragraphs, 
      'alternatively some looping would be needed here 

      'we check if paragraph next to Heading contains a list 
      If rngLIST.Paragraphs(1).Next.Range.ListParagraphs.Count > 0 Then 
       'we have the list, but it's not easy to select at once 
       Dim iLIST As List 
       For Each iLIST In ActiveDocument.Lists 
        If iLIST.Range.Start = rngLIST.Paragraphs(1).Next.Range.Start Then 
         'here we have it... selected 
         iLIST.Range.Select 

         'or any other of your code here 
        End If 
       Next 
      End If 
     End If 
    Loop While rngLIST.Find.Found 

End Sub 

Answer 2

我使用书签来标识标题，然后简单地返回它们之间的文本。但我不知道你不怀好意的But What I want is the List (not paragraph of the list)

截图

代码

Option Explicit 

Sub Sample() 
    Dim MyRange As Range 

    Selection.HomeKey Unit:=wdStory 

    On Error Resume Next 
    ActiveDocument.Bookmarks("MYStartBookMark").Delete 
    ActiveDocument.Bookmarks("MYEndBookMark").Delete 
    On Error GoTo 0 

    '~~> Find Heading 1 
    With Selection.Find 
     .ClearFormatting 
     .Style = ActiveDocument.Styles("Heading 1") 
     .Text = "" 
     .Replacement.Text = "" 
     .Forward = True 
     .Wrap = wdFindContinue 
     .Format = True 
     .Execute 
    End With 

    '~~> Move one space to the right 
    Selection.MoveRight Unit:=wdCharacter, Count:=1 

    '~~> Insert the start Book mark 
    With ActiveDocument.Bookmarks 
     .Add Range:=Selection.Range, Name:="MYStartBookMark" 
     .DefaultSorting = wdSortByName 
     .ShowHidden = False 
    End With 

    '~~> Find Heading 2 
    With Selection.Find 
     .ClearFormatting 
     .Style = ActiveDocument.Styles("Heading 2") 
     .Text = "" 
     .Replacement.Text = "" 
     .Forward = True 
     .Wrap = wdFindContinue 
     .Format = True 
     .Execute 
    End With 

    '~~> Move one space to the left 
    Selection.MoveLeft Unit:=wdCharacter, Count:=1 

    '~~> Insert the end Book mark 
    With ActiveDocument.Bookmarks 
     .Add Range:=Selection.Range, Name:="MYEndBookMark" 
     .DefaultSorting = wdSortByName 
     .ShowHidden = False 
    End With 

    '~~> Identify the range between the Start BookMark and End BookMark 
    Set MyRange = ActiveDocument.Range 
    MyRange.Start = MyRange.Bookmarks("MYStartBookMark").Range.End 
    MyRange.End = MyRange.Bookmarks("MYEndBookMark").Range.Start 

    '~~> This gives you that text 
    Debug.Print MyRange.Text 

    '~~> Delete the BookMarks 
    On Error Resume Next 
    ActiveDocument.Bookmarks("MYStartBookMark").Delete 
    ActiveDocument.Bookmarks("MYEndBookMark").Delete 
    On Error GoTo 0 
End Sub 

结果什么

其他测试

有人可能会说，如果我们不知道是什么的一个标题是什么？这是一个公平点，因为我们可以有两个场景。让我一起

1. 覆盖它们标题1之后，我们标题3
2. 文档中的最后一个标题为标题1，之后没有标题。

修改后的代码

Option Explicit 

Sub Sample() 
    Dim MyRange As Range 
    Dim MyArray 
    Dim strOriginal As String, strTemp As String 
    Dim numDiff As Long, i As Long, NextHd As Long 
    Dim NoNextHeading As Boolean 

    Selection.HomeKey Unit:=wdStory 

    On Error Resume Next 
    ActiveDocument.Bookmarks("MYStartBookMark").Delete 
    ActiveDocument.Bookmarks("MYEndBookMark").Delete 
    On Error GoTo 0 

    '~~> Get all the headings in the array 
    NoNextHeading = True 

    For i = LBound(MyArray) To UBound(MyArray) 
     strOriginal = RTrim$(MyArray(i)) 
     strTemp = LTrim$(strOriginal) 
     numDiff = Len(strOriginal) - Len(strTemp) 
     numDiff = (numDiff/2) + 1 
     '~~> If heading one is found and it is not the last heading 
     '~~> in the array then find what is the next heading 
     If numDiff = 1 And i <> UBound(MyArray) Then 
      strOriginal = RTrim$(MyArray(i + 1)) 
      strTemp = LTrim$(strOriginal) 
      numDiff = Len(strOriginal) - Len(strTemp) 
      numDiff = (numDiff/2) + 1 
      NextHd = numDiff 
      NoNextHeading = False 
      Exit For 
     End If 
    Next i 

    '~~> Find Heading 1 
    With Selection.Find 
     .ClearFormatting 
     .Style = ActiveDocument.Styles("Heading 1") 
     .Text = "" 
     .Replacement.Text = "" 
     .Forward = True 
     .Wrap = wdFindContinue 
     .Format = True 
     .Execute 
    End With 

    '~~> Move one space to the right 
    Selection.MoveRight Unit:=wdCharacter, Count:=1 

    '~~> Insert the start Book mark 
    With ActiveDocument.Bookmarks 
     .Add Range:=Selection.Range, Name:="MYStartBookMark" 
     .DefaultSorting = wdSortByName 
     .ShowHidden = False 
    End With 

    If NoNextHeading = False Then 
     '~~> Find Heading NextHd 
     With Selection.Find 
      .ClearFormatting 
      .Style = ActiveDocument.Styles("Heading " & NextHd) 
      .Text = "" 
      .Replacement.Text = "" 
      .Forward = True 
      .Wrap = wdFindContinue 
      .Format = True 
      .Execute 
     End With 

     '~~> Move one space to the left 
     Selection.MoveLeft Unit:=wdCharacter, Count:=1 
    Else 
     '~~> Move to the end of the document 
     ActiveDocument.Characters.Last.Select 
     Selection.Collapse 
    End If 

    '~~> Insert the end Book mark 
    With ActiveDocument.Bookmarks 
     .Add Range:=Selection.Range, Name:="MYEndBookMark" 
     .DefaultSorting = wdSortByName 
     .ShowHidden = False 
    End With 

    '~~> Identify the range between the Start Book Mark and End BookMark 
    Set MyRange = ActiveDocument.Range 
    MyRange.Start = MyRange.Bookmarks("MYStartBookMark").Range.End 
    MyRange.End = MyRange.Bookmarks("MYEndBookMark").Range.Start 

    '~~> This give you that text 
    Debug.Print MyRange.Text 

    '~~> Delete the BookMarks 
    On Error Resume Next 
    ActiveDocument.Bookmarks("MYStartBookMark").Delete 
    ActiveDocument.Bookmarks("MYEndBookMark").Delete 
    On Error GoTo 0 
End Sub