Option Explicit
'====================================================================================================
Sub FindDuples()
Dim dAll As New Dictionary, dDupl As New Dictionary
Dim arrTbl, colKey&, colF&, colI&, colO&, colDate&
Dim arrOut(), tx$, t!, r&, c&, n&

t = Timer                       ' засекаем время
arrTbl = Range("A2:J25").Value  ' диапазон таблицы

colKey = 2  ' номер столбца с идентификатором
colF = 4    ' фамилия
colI = 5    ' имя
colO = 6    ' отчество
colDate = 7 ' ДР

    For r = 1 To UBound(arrTbl, 1)
        tx = arrTbl(r, colF) & arrTbl(r, colI) & arrTbl(r, colO) & arrTbl(r, colDate)   ' сцепка "ФИОдата"

        If dAll.Exists(arrTbl(r, colKey)) Then                                          ' если в ОБЩЕМ словаре ЕСТЬ ключ-идетификатор
            If Not dDupl.Exists(arrTbl(r, colKey)) Then                                 ' если в словаре ДУБЛЕЙ НЕТ ключа-идентификатора
                If dAll(arrTbl(r, colKey)) <> tx Then dDupl.Add arrTbl(r, colKey), 0    ' если у хранимого и нового ключей не совпадают сцепки "ФИОдата", то добавляем ключ в словарь "плохих"
            End If
        Else
            dAll.Add arrTbl(r, colKey), tx                                              ' если ключа нет в общем словаре, то добавляем пару «ключ - сцепка "ФИОдата"»
        End If
    Next r

If dDupl.Count = 0 Then MsgBox "No duplicates", vbInformation, Format(Timer - t, "0.00 sec"): Exit Sub
ReDim arrOut(1 To UBound(arrTbl, 1), 1 To UBound(arrTbl, 2))

    For r = 1 To UBound(arrTbl, 1)
        If dDupl.Exists(arrTbl(r, colKey)) Then ' если текущий ключ есть в словаре ДУБЛЕЙ, то записываем в массив всю строку
            n = n + 1                           ' очередная строка НОВОГО массива
            For c = 1 To UBound(arrTbl, 2)
                arrOut(n, c) = arrTbl(r, c)
            Next c
        End If
    Next r

Application.ScreenUpdating = False
r = Application.Calculation: Application.Calculation = xlCalculationManual

Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(n, UBound(arrOut, 2)).Value = arrOut

Application.ScreenUpdating = True
MsgBox "Find duplicates: " & dDupl.Count & " in " & n & " rows", vbInformation, Format(Timer - t, "0.00 sec"): Exit Sub
Application.Calculation = r
End Sub