' процедуру - в модуль обрабатываемой книги
Sub compareLName()
    Dim rs
    Dim scn$, sq$
    
    scn = "Provider=Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=YES';data source=" & ThisWorkbook.Path
    sq = "select A.LNAME, A.SUMM from" & _
        " (select left([FROMNAME],instr(1,[FROMNAME],' ')-1) as LNAME,[PAYSUM] as SUMM from [Sheet1$]) as A" & _
        " inner join (select left([adresat],instrrev([adresat],' ')-1) as LNAME,[value] as SUMM from [Sheet2$]) as B" & _
        " on A.LNAME=B.LNAME and A.SUMM=B.SUMM"
    
    Set rs = CreateObject("adodb.recordset")
    
    rs.Open sq, scn
    ThisWorkbook.Worksheets(3).Cells(2, 2).CopyFromRecordset rs
    
    rs.Close
    Set rs = Nothing
End Sub

{фамилия_не_содержащая_пробелов_в_именительном_падеже}{пробел}{всё остальное}

{строка_не_содержащая_пробелов}{один_пробел}{фамилия_в_именительном_падеже}

' процедуру - в модуль обрабатываемой книги
' сверяет данные на первых двух листах ("фамилия", сумма) и вставляет в третий лист
' "фамилию" и сумму, которые есть и на первом и на втором листе
' REM эту процедуру Вы уже видели
Sub compareLName()
    Dim rs
    Dim scn$, sq$
    
    scn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=YES';data source=" & ThisWorkbook.FullName

    sq = "select A.LNAME, A.SUMM from" & _
        " (select left([FROMNAME],instr(1,[FROMNAME],' ')-1) as LNAME,[PAYSUM] as SUMM from [Sheet1$]) as A" & _
        " inner join (select mid([adresat],instr([adresat],' ')+1) as LNAME,[value] as SUMM from [Sheet2$]) as B" & _
        " on lcase(A.LNAME)=lcase(B.LNAME) and A.SUMM=B.SUMM"
    
    Set rs = CreateObject("adodb.recordset")
    
    rs.Open sq, scn
    ThisWorkbook.Worksheets(3).Cells(2, 2).CopyFromRecordset rs
    
    rs.Close
    Set rs = Nothing
    
    'Call UpdateRec
End Sub


' процедуру - в модуль обрабатываемой книги
' сохраняет книгу и на первых двух листах добавляет к "ФИО" префикс '~~'
' в тех строках, аналог которых есть на третьем листе
Sub UpdateRec()
    Dim cn, scs$, sq1$, sq2$
    
    ThisWorkbook.Save
    
    scs = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=YES';data source=" & ThisWorkbook.FullName

    sq1$ = "update [Sheet1$] as A set [FROMNAME]='~~' & [FROMNAME] where exists (" & _
        "select 'x' from [Sheet3$] as B" & _
        " where lcase(B.[Фамилия])=lcase(left(A.[FROMNAME],instr(1,A.[FROMNAME],' ')-1))" & _
        " and B.[Стоиомость]=A.[PAYSUM])"

    sq2$ = "update [Sheet2$] as A set [adresat]='~~' & [adresat] where exists (" & _
        "select 'x' from [Sheet3$] as B" & _
        " where lcase(B.[Фамилия])=lcase(mid(A.[adresat],instr(1,A.[adresat],' ')+1))" & _
        " and B.[Стоиомость]=A.[value])"
    
    Set cn = CreateObject("adodb.connection")
    cn.Open scs
    
    cn.Execute sq1
    cn.Execute sq2
    
    cn.Close
    Set cn = Nothing
    
    'Call DelMarcked
End Sub


' процедуру - в модуль обрабатываемой книги
' на первых двух листах удаляет строки, в которых колонка "ФИО" начинается с '~~'
' !! перед выполнением процедуры автофильтр на первых двух листах должен быть отключен
Sub DelMarcked()
    Dim iRow&, k&
    Dim arr
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    arr = Array(1&, 5&, 2&, 7&)
    
    For k = LBound(arr) To UBound(arr) Step 2
        With Worksheets(arr(k)).Cells(1, arr(k + 1))
            .Resize(.End(xlDown).Row).NumberFormat = "General"
            
            .AutoFilter Field:=1, Criteria1:="=~~*"
            iRow = .End(xlDown).Row - 1
            
            With .Offset(1)
                If iRow > 1 Then
                    .Resize(iRow).EntireRow.Delete
                ElseIf iRow = 1 Then
                    .EntireRow.Delete
                End If
            End With

            .AutoFilter
        
        End With
    Next k
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub