MS word vba - 查找文本和相关标题

Question

以下是一些工作代码，以防任何人需要它。 使用range.find函数找到关键字，一旦找到，就找到绝对行号。然后选择功能逐行向上滚动以查找标题级别1和2.结果存储在数组中并在完成后粘贴到Excel电子表格中。

如果有人有更优雅的方法，请告诉我。

'===================================================
'FIND KEY WORD AND ASSOCIATED LEVEL 1 AND 2 HEADINGS
'===================================================

Sub FIND_HDNG_2()

Dim SENTENCE As String
Dim hdng1name As String, hdng1No As String, hdng2name As String, hdng2No As String
Dim aRange As Range, Style_Range As Range
Dim CurPage As Integer, CurPage2 As Integer, CurPage3 As Integer
Dim hdng_STYLE As String
Dim LineNo As Integer, Hdng_LineNo As Integer
Dim SELECTION_PG_NO As Integer, RANGE_PG_NO As Integer
Dim HDNG_TXT As String
Dim ARRY(200, 5) As String
Dim COUNT As Integer
Dim HDNG1_FLAG As Boolean, HDNG2_FLAG As Boolean
Dim LINESUP As Integer

On Error Resume Next

COUNT = 1
Set aRange = ActiveDocument.Range
Do
    aRange.Find.Text = "must" ' the KEY WORD I am looking for
    aRange.Find.Execute Forward:=True
    If aRange.Find.Found Then
        'extract sentence
        LineNo = GetAbsoluteLineNum(aRange)
        RANGE_PG_NO = aRange.Information(wdActiveEndPageNumber)
        aRange.Expand Unit:=wdSentence
        aRange.Copy
        SENTENCE = aRange.Text
        aRange.Collapse wdCollapseEnd

        'find heading name and number
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, COUNT:=LineNo        'go to line no of the range
        LINESUP = 0
        Do
            LINESUP = LINESUP + 1
            Selection.MoveUp Unit:=wdLine, COUNT:=1
            Selection.HomeKey Unit:=wdLine
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            HDNG_TXT = Selection.Text

            'reached first page without finding heading
            SELECTION_PG_NO = Selection.Information(wdActiveEndPageNumber)
            If SELECTION_PG_NO = 1 Then     'exit if on first page
                hdng2No = "BLANK"
                hdng2name = "BLANK"
                Exit Do
            End If

            hdng_STYLE = Selection.STYLE
             If hdng_STYLE = "Heading 1,Heading GHS" And HDNG1_FLAG = False Then
                hdng1No = Selection.Paragraphs(1).Range.ListFormat.ListString
                hdng1name = Selection.Sentences(1)
                HDNG1_FLAG = True
                Exit Do
            End If

            If hdng_STYLE = "Heading 2" And HDNG2_FLAG = False Then
                hdng2No = Selection.Paragraphs(1).Range.ListFormat.ListString
                hdng2name = Selection.Sentences(1)
                HDNG2_FLAG = True
            End If
        Loop

    End If

    HDNG1_FLAG = False
    HDNG2_FLAG = False
    ARRY(COUNT, 1) = hdng1No
    ARRY(COUNT, 2) = hdng1name
    ARRY(COUNT, 3) = hdng2No
    ARRY(COUNT, 4) = hdng2name
    ARRY(COUNT, 5) = SENTENCE
    COUNT = COUNT + 1
Loop While aRange.Find.Found

Call PASTE_RESULT_EXCEL(ARRY)
End Sub

'===================================================
'PASTE RESULTS TO EXCEL
'===================================================

Sub PASTE_RESULT_EXCEL(ByRef ARY() As String)

Dim appExcel As Object
Dim wb As Object
Dim ws As Object
Dim min As String
Dim filename As String
Dim X As Integer, Y As Integer

filename = "DOC_NAME"

Set appExcel = CreateObject("Excel.Application")
With appExcel
    .Visible = True
    Set wb = .Workbooks.Add
    min = CStr(Minute(Now()))
    wb.SaveAs "D:\IPL\" + filename + "--" + min + ".xlsx"

    Set ws = wb.Worksheets(1)
    For X = 1 To 200
        For Y = 1 To 5
            ws.Cells(X + 5, Y).Value2 = ARY(X, Y)
        Next Y
    Next X

    Set ws = Nothing
    Set wb = Nothing
    Set appExcel = Nothing

End With

End Sub

'===================================================
'FIND ABSOLUTE LINE NUMBER OF KEY WORD
'===================================================

Function GetAbsoluteLineNum(r As Range) As Integer
    Dim i1 As Integer, i2 As Integer, COUNTER As Integer, rTemp As Range

    r.Select
    Do
        i1 = Selection.Information(wdFirstCharacterLineNumber)
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, COUNT:=1, Name:=""

        COUNTER = COUNTER + 1
        i2 = Selection.Information(wdFirstCharacterLineNumber)
    Loop Until i1 = i2

    r.Select
    GetAbsoluteLineNum = COUNTER
End Function