Option Explicit
'====================================================================================================
Sub СборИзWord()
Dim WA As Object, WD As Object
Dim arrFiles, iFile, iField, arrField(3), f&, n&, t!

arrFiles = ActiveWorkbook.Path
If Not FILE_ChooseFile(arrFiles, "Выберите файлы Word для сбора информации из полей", True, "Файлы MS Word", "*.doc*") Then Exit Sub

t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set WA = CreateObject("Word.Application")
[A2].Resize(ActiveSheet.UsedRange.Rows.Count, 1).EntireRow.Delete
On Error Resume Next

    For Each iFile In arrFiles
        f = 0: n = n + 1
        Application.StatusBar = "Собираем данные: файл " & n & " из " & UBound(arrFiles) + 1
        Set WD = WA.Documents.Open(iFile)

        For Each iField In Array(1, 3, 4, 6)
            arrField(f) = WA.ActiveDocument.Fields(iField).Result
            If Err Then Err.Clear: arrField(f) = "НЕТ ПОЛЯ"
            f = f + 1
        Next iField

        WA.ActiveDocument.Close
        ActiveSheet.Cells(n + 1, 1).Resize(1, 3).Value2 = arrField
'        DoEvents
    Next iFile

On Error GoTo 0
WA.Quit
Set WD = Nothing
Set WA = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
MsgBox "Успешно обработано файлов: " & UBound(arrFiles) + 1, vbInformation, Format$(Timer - t, "0.00 сек")
End Sub
'====================================================================================================
'ДИАЛОГОВОЕ ОКНО ВЫБОРА ФАЙЛОВ/ПАПКИ
'https://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/
'====================================================================================================
Function FILE_ChooseFile(tmpDefPath, Optional txtHead$, Optional Many As Boolean, Optional Description$, Optional ExtMask$) As Boolean
Dim n&

    If Len(txtHead) = 0 Then
        If Many Then txtHead = "Выберите файлы: " Else txtHead = "Выберите файл: "
    End If
    With Application.FileDialog(msoFileDialogFilePicker)
        If Many Then .AllowMultiSelect = True Else .AllowMultiSelect = False
        .Title = txtHead
        .Filters.Clear
        If Len(ExtMask) Then
            .Filters.Add Description, ExtMask, 1
'            .Filters.Add "Excel files", "*.xls*;*.xla*", 1
        Else
            .Filters.Add "All files", "*.*", 1
        End If
        .FilterIndex = 1
        .InitialFileName = tmpDefPath
        .InitialView = msoFileDialogViewDetails
        If .Show = 0 Then Exit Function
        ReDim tmpDefPath(.SelectedItems.Count - 1)
        For n = 1 To .SelectedItems.Count
            tmpDefPath(n - 1) = .SelectedItems(n)
        Next n
    End With
FILE_ChooseFile = True
End Function
'===========================================================================================