Reply to thread

Message

[QUOTE="andrewAF567, post: 7435849, member: 11526"]
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
[/QUOTE]

Verification