Find Duplicate Values and Copy all the duplicate rows into another sheet

Question

I have this master data in Sheet 1 (the actual data contains more than 140,000 rows):

header 1	header 2	header 3	Name	ID Number	header 4
cell 1	cell 2	cell 5	Ariana	123	cell 7
cell 3	cell 4	cell 6	Briana	124	cell 8
cell 9	cell 10	cell 11	Charlie	125	cell 9

I created conditional formatting for duplicate values in ID Number column. I wish to make the VBA copy all duplicate rows into Sheet 2.

For example, I have this new data I'll paste it into the master data (Sheet 1)

header 1	header 2	header 3	Name	ID Number	header 4
cell 1	cell 2	cell 6	Briana	124	cell 7
cell 9	cell 10	cell 11	Charlie	125	cell 8
cell 12	cell 18	cell 19	Dylan	126	cell 20

It means Briana and Charlie are both duplicate data.

I want VBA to copy the initial row for Briana and Charlie from the master data and also copy the duplicate row so then I can do double-check on the value inside both rows. Note: copy all duplicate values to sheet "Duplicate"

Here is my current code but when I run it there is run-time error '1004' says "That command cannot be used on multiple selection".

Option Explicit

Sub FilterAndCopy()

Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngMyData As Range, _
    helperRng As Range

Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Duplicate")

Application.ScreenUpdating = False

With wstSource
    Set rngMyData = .Range("A1:S" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)

With helperRng
    .FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
    .ClearContents
End With

Application.ScreenUpdating = True

End Sub

Answer 1

• When dealing with a large dataset, applying formulas and converting them may result in slow performance.
• Using a Dictionary to identify duplicated rows offers a more efficient solution.

Option Explicit
Sub FilterAndCopyDup()
    Dim objDic As Object, rngData As Range
    Dim i As Long, sKey As String, dupRng As Range, rowRng As Range
    Dim arrData, oSht1 As Worksheet, oSht2 As Worksheet
    Const KEY_COL = "E" ' Col [ID Number]
    Const COL_CNT = 19 ' Col A to S
    Set objDic = CreateObject("scripting.dictionary")
    Set oSht1 = Sheets("Sheet1")
    Set oSht2 = Sheets("Duplicate")
    ' load data from sheet1
    With oSht1
        Set rngData = .Cells(1, KEY_COL).Resize(.Range(KEY_COL & .Rows.Count).End(xlUp).Row)
    End With
    arrData = rngData.Value
    If Not VBA.IsArray(arrData) Then
        MsgBox "No data is on Sheet1.", vbCritical
        Exit Sub
    End If
    ' load data into Dict
    For i = LBound(arrData) + 1 To UBound(arrData)
        arrData(i, 1) = CStr(arrData(i, 1))
        sKey = arrData(i, 1)
        Set rowRng = oSht1.Cells(i, 1)
        If objDic.Exists(sKey) Then
            If dupRng Is Nothing Then
                Set dupRng = Application.Union(rowRng, objDic(sKey))
            Else
                Set dupRng = Application.Union(dupRng, rowRng, objDic(sKey))
            End If
        Else
            Set objDic(sKey) = rowRng
        End If
    Next i
    If Not dupRng Is Nothing Then
        Debug.Print dupRng.Address
       dupRng.EntireRow.Copy oSht2.Range("A2")
    End If
End Sub

---

btw, the helperRng is on Col U instead of Col T (which is next to the data table).

With wstSource
    Set rngMyData = .Range("A1:S" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)

• You can get the same range with a simpler code

Set helperRng = rngMyData.Columns(rngMyData.Columns.Count + 1)