Sub iSumma()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FIO As String
Dim Reply As Integer
With Workbooks("Kniga_A.xls").Worksheets("Лист1")
   iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
   .Range("D3:D" & iLR).ClearContents
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  For i = 2 To iLastRow
   If Not Cells(i, "A").Font.Bold = True Then
      FIO = Split(Cells(i, "A"), " ")(0) & " " & Left(Split(Cells(i, "A"), " ")(1), 1) & "." _
          & Left(Split(Cells(i, "A"), " ")(2), 1) & "."
        Set FoundCell = .Columns(2).Find(FIO, , xlValues, xlPart)
     If Not FoundCell Is Nothing Then
        FAdr = FoundCell.Address
      Do
        .Cells(FoundCell.Row, "D") = Cells(i, "B")
        Set FoundCell = .Columns(2).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     Else
       Reply = MsgBox("В книге_А нет фамилии: " & Cells(i, "A") & vbCrLf & "Добавить ?", vbYesNo)
       If Reply = vbYes Then
         iLR = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
         .Cells(iLR, "B") = FIO           'ФИО
         .Cells(iLR, "D") = Cells(i, "B") 'Отсюда
       End If
     End If
   End If
  Next
End With
End Sub

=ЕСЛИ(ЕОШИБКА(ВПР(ЛЕВСИМВ(B3;НАЙТИ(" ";B3)-1)&"*";[Kniga_B.xls]Лист1!$A:$B;2;0));0;ВПР(ЛЕВСИМВ(B3;НАЙТИ(" ";B3)-1)&"*";[Kniga_B.xls]Лист1!$A:$B;2;0))