Sub ParsingDoc()

Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer

FolderName = "D:\Pars" ' Директория с файлами

Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files

x = 2
For Each wd In objFiles
    If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
        Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
' 1. Выведение наименования файла в столбец A
sh1.Cells(x, 1) = wd.Name
         
' 2. Поиск даты Сведений в таблице № 1. Переменная dateA, da
Dim dateA As String, da As Long
dateA = wrdDoc.Tables(1).Cell(1, 1).Range
da = InStr(1, dateA, "", 1)
If da > 0 Then
dateA = Mid(dateA, da + 0, Len(dateA) - da - 3)
da = InStr(1, dateA, " г.", 1)
If da > 0 Then
dateA = Mid(dateA, 1, da - 1)
End If
End If
sh1.Cells(x, 2) = dateA

' 3. Поиск ФИО в таблице № 2. Переменная fio, fa
Dim fio As String, fa As Long
fio = wrdDoc.Tables(2).Cell(5, 2).Range
fa = InStr(1, fio, "", 1)
If fa > 0 Then
fio = Mid(fio, fa + 0, Len(fio) - fa - 5)
fa = InStr(1, fio, " род.", 1)
If fa > 0 Then
fio = Mid(fio, 1, fa - 1)
End If
End If
sh1.Cells(x, 3) = fio

' 4. Поиск Даты Договора оказания услуг в таблице № 2

x = x + 1
wrdDoc.Close
End If

Next wd
wordApp.Quit
End Sub