MS word vba - find text and associated headings - vba

Question

Here is some working code in case anyone needs it.
The key word is found using the range.find function, once found the absolute line number is found. Then the selection function scrolls up line by line to find heading levels 1 and 2. The results are stored in array and pasted onto an excel spreadsheet once complete.
If anyone has a more elegant method please let me know.
'===================================================
'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