Sub CopyNamesFromWordToExcel()

    ' Declare variables
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim excelApp As Object
    Dim excelWbk As Object
    Dim excelWks As Object
    Dim nameRange As Range
    Dim name As String

    ' Create instances of Word and Excel applications
    Set wordApp = CreateObject("Word.Application")
    Set excelApp = CreateObject("Excel.Application")

    ' Open the Word document
    Set wordDoc = wordApp.Documents.Open("C:\Path\To\Your\WordDocument.docx")

    ' Select the range of cells containing the names
    Set nameRange = wordDoc.Range(Start:=wordDoc.Content.Start, _
                                 End:=wordDoc.Content.End)

    ' Loop through each cell in the range
    For Each cell In nameRange.Cells

        ' Check if the cell contains a name
        If InStr(cell.Text, "Name: ") > 0 Then

            ' Extract the name from the cell text
            name = Mid(cell.Text, InStr(cell.Text, "Name: ") + Len("Name: "), _
                       InStr(cell.Text, vbCrLf) - InStr(cell.Text, "Name: ") - Len("Name: "))

            ' Add the name to the Excel sheet
            Set excelWbk = excelApp.Workbooks.Add
            Set excelWks = excelWbk.Worksheets(1)
            excelWks.Cells(excelWks.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = name

        End If

    Next cell

    ' Close the Word document
    wordDoc.Close False

    ' Clean up
    Set wordDoc = Nothing
    Set wordApp = Nothing
    Set excelWks = Nothing
    Set excelWbk = Nothing
    Set excelApp = Nothing

End Sub