Sub ПоискДвижений()
    '
    ' ПоискДвижений Макрос
    '
    ' Сочетание клавиш: Ctrl+у
    '
    Dim i As Long, c As Long, br As Long, lr As Long, count As Long, f As Long, s As Long, t As Long
    Dim A As Worksheet, B As Worksheet
    
    Set A = Worksheets("Page1")
    Set B = Worksheets("Лист2")

    'снимаем фильтры
    If A.FilterMode = True Then A.ShowAllData
    If B.FilterMode = True Then B.ShowAllData
 
    lr = A.cells(Rows.count, 1).End(xlUp).Row 'последняя заполненная строка первого листа
    br = B.cells(Rows.count, 4).End(xlUp).Row 'последняя заполненная строка второго листа
    
    'перебор строк первого листа
    For i = 2 To lr
        count = 0
        f = 0
        s = 0
        t = 0
        'перебор строк второго листа
        For c = 2 To br
            'если фио и дата рождения совпадает
            If A.cells(i, 4) = B.cells(c, 4) And CDate(A.cells(i, 6)) = CDate(B.cells(c, 5)) Then
                'счетчик+1
                count = count + 1
            End If
            'если найдено совпадение, то запоминаем строку первого совпадения
            If count = 1 Then
                f = c
            End If
            'если 2 совпадения, то запоминаем строку со вторым совпадением
            If count = 2 Then
               s = с
            End If
           
        Next c
        If count = 2 Then 'если нашлось два совпадения, добавляем строку ниже и копируем туда нужные ячейки
         A.Rows(i + 1).Insert
            B.cells(f, 9).Copy A.cells(i + 1, 10)
            B.cells(f, 10).Copy A.cells(i + 1, 12)
            B.cells(f, 14).Copy A.cells(i + 1, 21)
            'аналогично ниже
         A.Rows(i + 1).Insert
            B.cells(s, 9).Copy A.cells(i + 1, 10) '!!!!!!!!!!ТУТ ПАДАЕТ В ОШИБКУ 1004
            B.cells(s, 10).Copy A.cells(i + 1, 12)
            B.cells(s, 14).Copy A.cells(i + 1, 21)
        
            With A
                .Range(.cells(i, 1), .cells(i, 28)).Interior.ColorIndex = 8
            End With
            With A
                .Range(.cells(i + 1, 1), .cells(i, 28)).Interior.ColorIndex = 8
            End With
            With A
                .Range(.cells(i + 2, 1), .cells(i, 28)).Interior.ColorIndex = 8
            End With
            With B
                .Range(.cells(f, 1), .cells(c, 20)).Interior.ColorIndex = 8
            End With
            With B
                .Range(.cells(s, 1), .cells(c, 20)).Interior.ColorIndex = 8
            End With
        count = 0
        f = 0
        s = 0
        t = 0
        End If
        
    Next i
    MsgBox "Конец", vbInformation, "Конец"
End Sub

Sub ПоискДвижений()
'
' ПоискДвижений Макрос
'
' Сочетание клавиш: Ctrl+у
'
Dim i As Integer, c As Integer, br As Integer, lr As Integer, cells As Range, count As Integer, j As Integer

Dim A As Worksheet, B As Worksheet
Set A = Worksheets("Page1")
Set B = Worksheets("Лист2")

 
lr = A.cells(Rows.count, 1).End(xlUp).Row 'последняя заполненная строка первого листа
br = B.cells(Rows.count, 3).End(xlUp).Row 'последняя заполненная строка второго листа
For i = 2 To lr                             'перебор строк первого листа
count = 0
j = 0
    For c = 2 To br                                             'перебор строк второго листа
    If A.cells(i, 4) = B.cells(c, 4) And A.cells(i, 6) = B.cells(c, 5) Then     'ЗДЕСЬ ПРОВЕРЯЕТСЯ СОВПАДЕНИЕ ФИО И ДР ЯЧЕЙКИ ПЕРВОЙ ТАБЛИЦЫ С ЯЧЕЙКАМИ ВТОРОЙ ТАБЛИЦЫ
         count = count + 1                                                      'ЗДЕСЬ СЧЕТЧИК СОВПАДЕНИЙ
    End If
        If count = 1 Then                                                       '
            j = c                                                               'ЗДЕСЬ ЗАПОМИНАЕМ НОМЕР СТРОКИ ПЕРВОГО СОВПАДЕНИЯ
        End If
    If count = 2 Then                                                           'ЕСЛИ ПОПАЛОСЬ ТАК, ЧТО У ЯЧЕЙКИ ПЕРВОГО ЛИСТА НЕСКОЛЬКО СОВПАДЕНИЙ СО ВТОРЫМ ЛИСТОМ
        Rows(i + 1 & ":" & i + 1).Insert                                        'ТО ДОБАВЛЯЕМ ДВЕ СТРОКИ(ЧТОБ ЗАПИСАТЬ ПЕРВОЕ СОВПАДЕНИЕ И ВТОРОЕ)
        Rows(i + 1 & ":" & i + 1).Insert                                        '
        B.cells(j, 9).Copy                                                      'ДАЛЕЕ КОПИРУЕМ И ВСТАВЛЯЕМ НУЖНЫЕ СТОЛБЦЫ В ПУСТЫЕ СТРОКИ
        A.cells(i + 1, 10).Paste
        B.cells(j, 10).Copy
        A.cells(i + 1, 12).Paste
        B.cells(j, 14).Copy
        A.cells(i + 1, 21).Paste
        
        B.cells(c, 9).Copy
        A.cells(i + 2, 10).Paste
        B.cells(c, 10).Copy
        A.cells(i + 2, 12).Paste
        B.cells(c, 14).Copy
        A.cells(i + 2, 21).Paste
        
     With A
        .Range(.cells(i, 1), .cells(i, 28)).Interior.ColorIndex = 8             'ЗДЕСЬ УЖЕ КРАСИМ СТРОКИ, У КОТОРЫХ ВЫПОЛНИЛОСЬ УСЛОВИЕ ВЫШЕ
    End With
     With A
        .Range(.cells(i + 1, 1), .cells(i, 28)).Interior.ColorIndex = 8
        End With
     With A
        .Range(.cells(i + 2, 1), .cells(i, 28)).Interior.ColorIndex = 8
        End With
     With B
        .Range(.cells(j, 1), .cells(c, 20)).Interior.ColorIndex = 8
        End With
     With B
        .Range(.cells(c, 1), .cells(c, 20)).Interior.ColorIndex = 8
        End With
        
    End If
    
    Next c
    
Next i


'

End Sub