Sub PoiskFIO_Name()
Dim Found_Name As Range
Dim FAdr As String
Dim j As Integer
Dim n As Integer
Dim dic As Object
  Range("E3:J12").ClearContents
 For j = 3 To 12
   Set dic = CreateObject("Scripting.Dictionary")
   n = 1
   Set Found_Name = Columns("A").Find(Cells(j, "D"), , xlValues, xlWhole)
    If Not Found_Name Is Nothing Then
      FAdr = Found_Name.Address
      Do
         If Not dic.Exists(Found_Name & Found_Name.Offset(, 1)) Then
           dic.Item(Found_Name & Found_Name.Offset(, 1)) = dic.Item(Found_Name & Found_Name.Offset(, 1))
             Cells(j, 4 + n) = Found_Name.Offset(, 1)
             n = n + 1
         End If
           Set Found_Name = Columns("A").FindNext(Found_Name)
      Loop While Found_Name.Address <> FAdr
          Cells(j, 9) = n - 1
    End If
 Next
End Sub