Option Explicit
Private Sub ПоискДубликатов()
' таблица должна начинаться с ячейки A1 текущего листа
Dim rng As Range, cl As Range
Dim arr(), arrID() As Long, arrDupl(), x, y
Dim tm!, i&, n&, r&, c%, col%, txt$
Application.ScreenUpdating = 0: On Error GoTo er: tm = Timer: txt = "Duplicates"
arr = ActiveSheet.UsedRange.Value: r = UBound(arr, 1) - 1: c = UBound(arr, 2)

    For i = 1 To c
        If arr(1, i) = "id" Then col = i: Exit For ' ищем столбец «id» в массиве
    Next i

Set rng = Cells(2, col).Resize(r, 1)
ReDim arrID(1 To r)

    For Each cl In rng
        If Application.WorksheetFunction.CountIf(rng, cl) > 1 Then n = n + 1: arrID(n) = cl.Row
    Next cl

If n = 0 Then MsgBox "Дубли не найдены…", vbInformation, "КЛЮЧИ УНИКАЛЬНЫ": GoTo ex
ReDim Preserve arrID(1 To n)
ReDim arrDupl(1 To n, 1 To c)
r = 0: Set rng = Nothing
    For Each x In arrID
        r = r + 1
        For i = 1 To c
            arrDupl(r, i) = arr(x, i)
        Next i
        If rng Is Nothing Then Set rng = Cells(x, 1) Else: Set rng = Application.Union(rng, Cells(x, 1))
    Next x
rng.EntireRow.Delete

On Error Resume Next: Application.DisplayAlerts = 0
Worksheets(txt).Delete
On Error GoTo er:: Application.DisplayAlerts = 1
Worksheets.Add.Name = txt
Worksheets(txt).Tab.Color = vbGreen

[a1].Resize(n, c).Value = arrDupl

MsgBox "Дубли (" & n & ") строк вырезаны!" & vbLf & vbLf & "Время работы макроса (сек.): " & Round(Timer - tm, 4), vbInformation, "ГОТОВО"
GoTo fin
er: MsgBox "Непредвиденная ошибка!", vbCritical, "FATAL ERROR"
ex: MsgBox "Отмена выполнения…", vbInformation, "EXIT"
fin: Application.DisplayAlerts = 1: Application.ScreenUpdating = 1
End Sub

Option Explicit

Sub test()
'   ----------------------------------------------
    Dim dic As Object, ikey
    Dim i&, arr(), txt$, j%, x&, sht As Worksheet
'   ----------------------------------------------
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    Set sht = ThisWorkbook.Worksheets("Дубли")
    If Not sht Is Nothing Then sht.Delete
    On Error GoTo 0
    arr = sht1.UsedRange.Value
    For i = 2 To UBound(arr)
        txt = arr(i, 7)
        dic.Item(txt) = dic.Item(txt) + 1
    Next i
    For Each ikey In dic.Keys
        If dic.Item(ikey) = 1 Then dic.Remove (ikey)
    Next ikey
    x = 1
    For i = 1 To UBound(arr)
        txt = arr(i, 7)
        If dic.Exists(txt) Then
            x = x + 1
            For j = 1 To UBound(arr, 2)
                arr(x, j) = arr(i, j)
            Next j
        End If
    Next i
    Set sht = ThisWorkbook.Worksheets.Add(after:=sht1)
    With sht
        .[a1].Resize(x, UBound(arr, 2)) = arr
        .Name = "Дубли"
        .Columns.AutoFit
    End With
    Application.DisplayAlerts = True
End Sub