How to get a list that is immediately after heading 1 in Word VBA?

Question

The following shows pattern of a very long document:

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

When I use Document.Lists I get all the lists in the document. When Iterate using Document.Paragraphs where Document.Paragraphs(i).Style = "Heading 1" I get all the headings.

But What I want is the List (not paragraph of the list) which is immediately after "Heading 1"

Answer 1

I use bookmarks to identify the Headings and then simply return the text between them. But I am not sure by what you mean by But What I want is the List (not paragraph of the list)

ScreenShot

Code

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

Result

OTHER TESTS

One might say that what if we do not know what the next heading is? Which is a fair point as we can have two more scenarios. Let me cover them together

1. After Heading 1, we have Heading 3
2. The last Heading in a document is Heading 1 and after that there are no headings.

MODIFIED CODE

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

Answer 2

Assuming that your document can look like one on the picture below:

Using this proposed code you would be able to select first list (immediate after heading) and other similar lists located below Heading but not the second (there is additional paragraph between heading and list- for that situation see additional comments inside code).

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