Search column a for duplicate data and copy entire row to duplicate sheet

Hello Allen,

This macro assumes the worksheets are named "Sheet1" and "Duplicates". Row one on both worksheets is also assumed to to have headers. Copy and paste this code into a VBA module. You can then run the macro manually or attach it to a button.

Sub CopyDuplicates()

    Dim Cell As Range
    Dim DstWks As Worksheet
    Dim Key As String
    Dim Matches As Collection
    Dim R As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim SrcWks As Worksheet
    
        Set SrcWks = Worksheets("Sheet1")
        Set DstWks = Worksheets("Duplicates")
        
            Set Rng = SrcWks.Range("A2")
            Set RngEnd = SrcWks.Cells(Rows.Count, Rng.Column).End(xlUp)
            If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = SrcWks.Range(Rng, RngEnd)
        
            DstWks.UsedRange.Offset(1, 0).Clear
            R = DstWks.UsedRange.Row + 1
            
            Set Matches = New Collection
            
                For Each Cell In Rng
                    Key = Trim(Cell)
                    On Error Resume Next
                        Matches.Add Cell.Row, Key
                        If Err <> 0 Then
                            Cell.EntireRow.Copy DstWks.Rows(R)
                            R = R + 1
                        End If
                    On Error GoTo 0
                Next Cell
                
End Sub

Hi,

Here's some code that may help. It looks at column A then move the dups to the Dup sheet.

Sub DupMove_code()
Dim I As Long
Dim lastrow
lastrow = Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To lastrow
    If WorksheetFunction.CountIf(Range("A1:A" & I), Range("A" & I)) > 1 Then
        Rows(I).Copy Destination:=Sheets("Duplicate").Range("A" & Sheets("Duplicate").Range("A65536").End(xlUp).Row + 1)
    End If
Next
End Sub