Как найти дубликаты объединений столбцов одной строки на одном листе?

Sub ttt()
    Dim a(), i&, t$, ind&, x&
 
    ' Отключаем обновление экрана, чтобы код быстрее работал.
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        a = Sheets(1).UsedRange.Columns(3).Resize(, 6).Value
        For i = 2 To UBound(a)
            t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
            .Item(t) = 0&
        Next
 
        a = Sheets(2).UsedRange.Columns(4).Resize(, 6).Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
        For i = 2 To UBound(a)
            t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6)
            If .exists(t) Then
                ind = ind + 1: For x = 1 To UBound(a, 2): b(ind, x) = a(i, x): Next
            End If
        Next
    End With
 
    If ind > 0 Then Workbooks.Add(1).Sheets(1).[a1].Resize(ind, UBound(b, 2)) = b
    Application.ScreenUpdating = True
 
End Sub

=ЕСЛИ(СЧЁТЕСЛИМН($C$2:$C$21141;C2;$D$2:$D$21141;D2)>1;"Повтор";"")

Sub ttt()
  Dim a(), b(), i&, j&, k&, record&, s$
    With Sheets(1)
        a = .Range(.Cells(2,1), .Cells(.Rows.Count, 4).End(xlUp)).Value
    End With
    ReDim b(1 To UBound(a, 1), 1 To 4)
    record = 0
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(a, 1)
            s = a(i, 3) & "|" & a(i, 4)
            If .exists(s) Then
                j = .Item(s)
                If j Then
                    record = record + 1
                    For k = 1 To 4: b(record, k) = a(j, k): Next
                    .Item(s) = 0
                End If
                ' убрать следующие две строки, если необходимо копировать только первую запись имеющуюю дубликаты
                record = record + 1
                For k = 1 To 4: b(record, k) = a(i, k): Next
            Else
                .Add s, i
            End If
        Next
    End With
    Sheets(2).UsedRange.Offset(1).Clear
    If record Then Sheets(2).[a2].Resize(record, 4).Value = b
End Sub

Sub ttt()
  Dim a(), b(), i&, j&, k&, record&, s$
    With Sheets(1)
        a = .Range(.[a2], .Cells(.Rows.Count, 4).End(xlUp)).Value
    End With
    ReDim b(1 To UBound(a, 1), 1 To 5)
    record = 0
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(a, 1)
            s = a(i, 3) & "|" & a(i, 4)
            If .exists(s) Then
                j = .Item(s)
                If j < 0 Then
                    record = record + 1
                    For k = 1 To 4: b(record, k) = a(-j, k): Next
                    b(record, 5) = s
                    .Item(s) = 1
                End If
                record = record + 1
                For k = 1 To 4: b(record, k) = a(i, k): Next
                b(record, 5) = s
                .Item(s) = .Item(s) + 1
            Else
                .Add s, -i
            End If
        Next
        For i = 1 To record
            b(i, 5) = .Item(b(i, 5))
        Next
    End With
    Sheets(2).UsedRange.Offset(1).Clear
    If record Then Sheets(2).[a2].Resize(record, 5).Value = b
End Sub