Code for duplicate rows?

[fpd833]

Following up on a previous post.

I have a list of data in columns A:I. I need to find all duplicate rows in
the used range based on the data in col G, cut the all duplicates and paste
into another worksheet in the workbook.

Tom Ogilvy provided the following routine, but this leaves behind 1 of the
duplicate rows. Lets say I have 3 rows that have the same data in col G, is
it possible to cut and past all 3 rows into the other sheet? Thanks in
advance for any help you can provide.

Thanks!

Sub ABC()
Dim rng As Range, rng1 As Range
Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
ActiveSheet.Columns(10))
rng.Formula = "=if(Countif($G$1:G1,G1)>1,na(),"""")"
On Error Resume Next
Set rng1 = rng.SpecialCells(xlFormulas, xlErrors)
On Error GoTo 0
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
rng1.EntireRow.Delete
Worksheets("Sheet2").Columns(10).ClearContents
End If
ActiveSheet.Columns(10).ClearContents
End Sub

 

[Tom Ogilvy]

Column G
A
A '<== duplicate
A '<== duplicate

Is my interpretation of duplicate records and the code does that. If what
you describe now is what you actually want, the modification is simple:

Sub ABC()
Dim rng As Range, rng1 As Range
Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
ActiveSheet.Columns(10))
rng.Formula = "=if(Countif($G:G,G1)>1,na(),"""")"
On Error Resume Next
Set rng1 = rng.SpecialCells(xlFormulas, xlErrors)
On Error GoTo 0
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
rng1.EntireRow.Delete
Worksheets("Sheet2").Columns(10).ClearContents
End If
ActiveSheet.Columns(10).ClearContents
End Sub

 

[fpd833]

Thanks Tom....that change makes sense! However this routine causes Excel to
stop responding. Any ideas?

 

[Tom Ogilvy]

Sub ABC()
Dim rng As Range, rng1 As Range
Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
ActiveSheet.Columns(10))
rng.Formula = "=if(Countif($G:$G,G1)>1,na(),"""")"
On Error Resume Next
Set rng1 = rng.SpecialCells(xlFormulas, xlErrors)
On Error GoTo 0
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
rng1.EntireRow.Delete
Worksheets("Sheet2").Columns(10).ClearContents
End If
ActiveSheet.Columns(10).ClearContents
End Sub

code worked fine for me.

Tested in xl2003

How many rows are you trying to process.

 

[fpd833]

I'm running through about 3000 rows of data. When I run the macro Excel tells
me "Calaculating Cells 100%".....it does this twice but hangs at the second
100%. I have left it running for 30 minutes.....

Thanks Tom!

 

[Tom Ogilvy]

Here is a modification:

Sub ABC()
Dim tt As Single
Dim calc As Long
Dim rng As Range, rng1 As Range
tt = Timer
calc = Application.Calculation
Application.Calculation = xlManual
Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
ActiveSheet.Columns(10))
For Each cell In rng
cell.Formula = "=if(Countif($G$1:$G$5000,G" & cell.Row & ")>1,na(),"""")"
ActiveSheet.Calculate
cell.Formula = cell.Value
If cell.Row Mod 10 = 0 Then Application.StatusBar = cell.Row
Next
On Error Resume Next
Set rng1 = rng.SpecialCells(xlConstants, xlErrors)
On Error GoTo 0
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
rng1.EntireRow.Delete
Worksheets("Sheet2").Columns(10).ClearContents
End If
ActiveSheet.Columns(10).ClearContents
Application.Calculation = calc
Application.StatusBar = False
Debug.Print Timer - tt
End Sub


took about 10 seconds for me with 3500 rows.