Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel

[andrewAF567]

Hi there, I need to extract all Heading 3 Titles and all the content below each Heading 3 (Including headings 4) from a large Word File, and paste every Heading 3, and Content into a different cell. Please help. All I have for now, but not working is this.

Sub Macro1()

Dim i As Integer
Dim sectCount As Integer
Dim aRange As Range
Dim aSection As String
Dim aREQ As String
Dim posSt As Long
Dim posEnd As Long
Dim counter As Integer

' Macro1 Macro
' Open Excel file
Set xl = CreateObject("Excel.Sheet")
Set xlBook = xl.Application.Workbooks.Open("\\.....Template_WF_Stories_upload.xlsx")


'Find the first requirement heading


Windows("Document1.docx").Activate
ActiveDocument.Range.GoTo What:=wdGoToHeading, Which:=wdGoToFirst

Set aRange = ActiveDocument.Range( _
Start:=ActiveDocument.Range.GoTo(wdGoToHeading, wdGoToFirst).Start, _
End:=ActiveDocument.Range.GoTo(wdGoToLine, wdGoToLast).End)

sectCount = aRange.Sentences.COUNT
counter = 0

For i = 0 To sectCount
posSt = aRange.GoTo(wdGoToLine, wdGoToNext, i + 1).Start
posEnd = aRange.GoTo(wdGoToLine, wdGoToNext, i + 2).End
Set aStyle = ActiveDocument.Range(posSt, posEnd).Style

If aStyle = "Heading 3" Or i = sectCount Then
counter = counter + 1
aREQ = aSection
MsgBox (aREQ)
xlBook.Worksheets("Stories").Cells(1 + counter, 4).Value = aREQ

aSection = ActiveDocument.Range(posSt, posEnd).Text
Else
aSection = aSection + ActiveDocument.Range(posSt, posEnd).Text
End If

Next i

'For i = 1 To iParCount
'ActiveDocument.Paragraphs (i)
' Paste the table in the new document.
'Next i

MsgBox ("Done")

End Sub