Move various duplicate rows to new sheet

[parscon]

I need a VBA code that can move arious duplicate rows to new sheet base column A


Data on Sheet1 Before run VBA code : You see base will be column A and will move all the row.


When Run VBA all duplicate data will be move to sheet2


and the sheet1 after VBA


Note : I have about 420 000 Row base on column A
Thank you very much

Best Regards

[mrojas]

The code below, although not tested, it should get you started

   
 Dim lngRows As Long    
Dim strColumnA As String
    Dim lngNewRow As Long
    
    lngRows = Sheets(2).Range("A1").CurrentRegion.Rows.Count
    lngNewRow = 1
    
    Sheets(1).Select
    For i = 2 To lngRows
        strColumnA = Range("A" & i)
        If strColumnA = Range("A" & i + 1) Then ' If row 2 in column A is same as row 3
            Sheets(1).Select ' Make sure still on sheet 1
            Range("A" & i & ":I" & i).Select
            Selection.Copy
            Sheets(2).Select ' Switch to sheet 2
            Range("A" & lngNewRow).Select
            ActiveSheet.Paste
            lngNewRow = lngNewRow + 1
            Sheets(1).Select ' Switch back to sheet 1
            Range("A" & i).Select ' Select range
            Selection.ClearContents ' Since it's a duplicte, clear its contents
        End If
    Next i

To put it all together, create a button and place the code above in its click event.

[georgiboy]

Hi there.

I may have missed the point here but my logic tells me it would be quicker to move the unique values to a new sheet rather than the duplicate ones as it seems there will be more duplicates in your data.

It may not be what you need but here is my code for achieving the above.

Sub DupRemove()

    Dim rCell As Range
    
    For Each rCell In Sheet1.Range("A1:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Cells
        If WorksheetFunction.CountIf(Sheet1.Range("A:A"), rCell.Value) < 2 Then
            Sheet1.Range(rCell, rCell.Offset(, 8)).Cut _
                Sheet2.Range("A" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1)
        End If
    Next rCell
    
End Sub

Hope this helps.

George

[Bob Phillips]

One way

Public Sub NewData()
Dim ws As Worksheet
Dim rng As Range
Dim filtered As Range

    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = "Non-Duplicates"
    Worksheets("Sheet1").Copy After:=Worksheets(Worksheets.Count - 1)
    Set ws = ActiveSheet
    With ws
    
        .Name = "Duplicates"
        .Columns(1).Insert
        .Rows(1).Insert
        .Range("A1").Value = "tmp"
        .Range("A2").Resize(.UsedRange.Rows.Count).Formula = "=COUNTIF(B:B,B2)=1"
        Set rng = .Range("A1").Resize(.UsedRange.Rows.Count, .UsedRange.Columns.Count)
        rng.AutoFilter Field:=1, Criteria1:="=TRUE"
        On Error Resume Next
        Set filtered = rng.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not filtered Is Nothing Then
            filtered.EntireRow.Copy Worksheets("Non-Duplicates").Range("A1")
            Worksheets("Non-Duplicates").Rows(1).Delete
            Worksheets("Non-Duplicates").Columns(1).Delete
            filtered.EntireRow.Delete
        End If
        .Columns(1).Delete
    End With
End Sub