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