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

Question

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

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

当我使用时，Document.Lists我会得到文档中的所有列表。当使用我得到所有标题的Document.Paragraphs地方进行迭代时 。Document.Paragraphs(i).Style = "Heading 1"

但我想要的是紧随“标题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