Private strWorkbook As String
Private strSheet As String
Sub FindWordCopySentence()

    Dim appExcel As Object
    Dim strSheet As Object
    Dim aRange As Range
    Dim intRowCount As Integer
    intRowCount = 1
    Set aRange = ActiveDocument.Range
    With aRange.Find
        Do
            .Text = "shall" ' the word I am looking for
            .Execute
            If .found Then
                aRange.Expand Unit:=wdSentence
                aRange.Copy
                aRange.Collapse wdCollapseEnd
                If objSheet Is Nothing Then
                    Set appExcel = CreateObject("Excel.Application")
                     'Change the file path to match the location of your test.xls
                     
                    Set strSheet = BrowseForFile("Select Workbook", True)
                    If Not strSheet = vbNullString Then
                    
                    strSheet = InputBox("Please enter the name of the Sheet", "Worksheet", "Please enter the name of the Sheet")
                    If Not strSheet = vbNullString Then
                    
                    intRowCount = 1
                End If
                objSheet.Cells(intRowCount, 1).Select
                objSheet.Paste
                intRowCount = intRowCount + 1
            End If
        Loop While .found
    End With
    If Not objSheet Is Nothing Then
        appExcel.Workbooks(1).Close True
        appExcel.Quit
        Set objSheet = Nothing
        Set appExcel = Nothing
    End If
    Set aRange = Nothing
End Sub
Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_Handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
err_Handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

Option Explicit

Private Const xlWB As String = "C:\Path\Empty Excel File name.xlsx"
Private Const xlSheet As String = "Sheet1"

Sub ExtractText()
Dim oDoc As Document
Dim oRng As Range
    Set oDoc = ActiveDocument
    Set oRng = oDoc.Range
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Do While .Execute()
            If oRng.Text Like "Speaker*" Then
                WriteToWorksheet xlWB, xlSheet, oRng.Text
            End If
        Loop
    End With
lbl_Exit:
    Exit Sub
End Sub

Private Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

Option Explicit

Private Const xlWB As String = "C:\Path\Empty Excel File name.xlsx"
Private Const xlSheet As String = "Sheet1"
Private vList() As Variant

Sub ExtractText()
    vList = Array("Speaker 1", "Speaker 2", "Speaker 3")
    Dim oDoc As Document
    Dim oRng As Range
    Dim i As Long

    Set oDoc = ActiveDocument
    Set oRng = oDoc.Range
    With oRng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Name = "Times New Roman"
        .Font.Bold = True
        Do While .Execute()
            For i = 0 To UBound(vList)
                If oRng.Text = CStr(vList(i)) Then
                     WriteToWorksheet xlWB, xlSheet, oRng.Text
                    Exit For
                 End If
            Next i
        Loop
    End With
lbl_Exit:
    Exit Sub
End Sub