Option Explicit

Sub ExtractData()
'Graham Mayor - https://www.gmayor.com - Last updated - 23 Nov 2021
Dim oDoc As Document
Dim oSource As Document
Dim oRng As Range, oDocRng As Range
Dim lSec As Long, lPara As Long
Dim fDialog As FileDialog
Dim strPath As String, strFile As String

    If Documents.Count = 0 Then Documents.Add

    Set oDoc = ActiveDocument

    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "Select folder and click OK"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then
            MsgBox "Cancelled By User", , "List Folder Contents"
            Exit Sub
        End If
        strPath = fDialog.SelectedItems.Item(1)
        If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
    End With

    strFile = Dir$(strPath & "*.docx")
    While strFile <> ""
        Set oSource = Documents.Open(strPath & strFile)
        Set oRng = oSource.Range
        With oRng.Find
            Do While .Execute("^m")
                oRng.Text = ""
                oRng.InsertBreak wdSectionBreakNextPage
                oRng.Collapse 0
            Loop
        End With

        If Len(oDoc.Range) > 1 Then
            Set oRng = oDoc.Range
            oRng.Collapse 0
            oRng.InsertBreak wdPageBreak
        End If

        For lSec = 1 To oSource.Sections.Count
            For lPara = 1 To oSource.Sections(lSec).Range.Paragraphs.Count
                If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Text Like "*System Safety Assessment Summary*" Then
                    If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                        Set oDocRng = oDoc.Range
                        oDocRng.Collapse 0
                        oDocRng.Text = oSource.Name & vbCr
                        oDocRng.Collapse 0
                        oDocRng.FormattedText = oSource.Sections(lSec).Range.FormattedText
                        oDocRng.InsertParagraphAfter
                        Exit For
                    End If
                End If
            Next lPara
            For lPara = 1 To oSource.Sections(lSec).Range.Paragraphs.Count
                If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Text Like "*Hardware Considerations*" Then
                    If oSource.Sections(lSec).Range.Paragraphs(lPara).Range.Style = "ForCertPlanTOC" Then
                        Set oDocRng = oDoc.Range
                        oDocRng.Collapse 0
                        oDocRng.FormattedText = oSource.Sections(lSec).Range.FormattedText
                        oDocRng.InsertParagraphAfter
                        Exit For
                    End If
                End If
            Next lPara
        Next lSec
        If oDoc.Sections.Count > 2 Then
            Set oRng = oDoc.Sections.Last.Range.Previous
            oRng.End = oDoc.Range.End
            oRng.Delete
        End If

        oSource.Close SaveChanges:=wdDoNotSaveChanges
        strFile = Dir$()
    Wend
lbl_Exit:
    Set fDialog = Nothing
    Set oSource = Nothing
    Set oDoc = Nothing
    Set oRng = Nothing
    Set oDocRng = Nothing
    Exit Sub
End Sub