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.
http://i62.tinypic.com/wmcck9.png

When Run VBA all duplicate data will be move to sheet2
http://i62.tinypic.com/210hmp1.png

and the sheet1 after VBA
http://i62.tinypic.com/2ni9r8o.png

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