Option Base 0

Sub test()
     Dim arr(), a, i&, ii&, it, ul, t&, x As Byte, b As Variant
     Dim tm!: tm = Timer
     Application.ScreenUpdating = False
     arr = Range([Z8], Cells(Rows.Count, 3).End(xlUp)).Value
     b = Array(1, 2, 3, 21, 22, 24)
     ReDim out(1 To UBound(arr), 1 To 7)

     With CreateObject("Scripting.Dictionary")
         For i = 1 To UBound(arr, 1)
             it = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
             ul = arr(i, 21) & "|" & arr(i, 22) & "|" & arr(i, 24)
             If Not .exists(it) Then
                 a = Array(i, CreateObject("scripting.dictionary"))
                 a(0) = i
                 a(1).Item(ul) = 0&
                 .Item(it) = a
             Else
                 a = .Item(it)
                 If Not a(1).exists(ul) Then
                     If a(0) > 0 Then
                         ii = ii + 1
                         t = a(0): a(0) = 0
                         out(ii, 1) = ii
                         For x = 2 To 7: out(ii, x) = arr(t, b(x - 2)): Next
                     End If
                     a(1).Item(ul) = 0&
                     ii = ii + 1
                     out(ii, 1) = ii
                     For x = 2 To 7: out(ii, x) = arr(i, b(x - 2)): Next
                     .Item(it) = a
                 End If
             End If
         Next i

     End With
     With Sheets("Результат")
         .[a1].CurrentRegion.Clear
         .[a1].Resize(1, 7).Value = Array("№", "ФИО", "Д/Р", "место рожд.", "улица", "дом", "кв")
         .[a2].Resize(ii, 7).Value = out
         .Activate
         With .[a1].CurrentRegion
             .Columns.AutoFit
             .Borders().LineStyle = xlContinuous
         End With

     End With
     Application.ScreenUpdating = True
     MsgBox Timer - tm & " сек."
     Application.StatusBar = False
End Sub