How to copy text from Word to Excel according to a list?

[syl3786]

Hi community,



I'm sorry that I have questions to ask again...

I would like to use word macro to copy specific text with specific font style from Word document to Microsoft Excel according to a list. I drafted the following macro based on VBA Express : Word - Extract sentences containing a specific word to excel file. However, I don't know how to copy specific text with specific font style from Word document to Microsoft Excel according to a list. Does anyone have any solution for that?

Expected outcome (Excel file): Loading Google Sheets (Copy times new roman, font size 12)
List: Loading Google Sheets
Test document: Loading Google Docs

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