Copy duplicate data to new worksheet

Posted by A.R. on May 14, 2001 12:34 PM

I have a column displaying company name. I have to copy the rows that have the same company names to a new worksheet. For example, there are two "Company A" in rows 3 and 4, each with a different address, ID # etc. There are three Company B, 2 Company C, etc. I would copy the above data to a new worksheet. This is a very large worksheet (18,000 rows) and I tried using the Filter feature, but that only deletes duplicate records. Is there a way for Excel to find those duplicate data (company name) all at once, and then copy those rows to a new worksheet?

Posted by Dave Hawley on May 14, 2001 2:21 PM

Hi A.R

Here is some code, that I have not tested. It assumes your data is in Columns A:C with Column A having the Company names. It also assumes Column D is empty and you have a sheet called "Duplicates".

Sub CopyDuplicates()
'Written by OzGrid Business Applications
'www.ozgrid.com

Dim rAllRows As Range
Dim rTake1 As Range
Dim rTake2 As Range

Set rAllRows = Range("A2", Range("A65536").End(xlUp))

rAllRows.Offset(0, 3).FormulaR1C1 = _
"=IF(COUNTIF(C1,RC[-3])>1,1,""no"")"

Set rTake1 = Range("D2:D10000").SpecialCells _
(xlCellTypeFormulas, xlNumbers).Offset(0, -3)
Set rTake2 = Range("D10001", Range("D65536").End(xlUp)).SpecialCells _
(xlCellTypeFormulas, xlNumbers).Offset(0, -2)

Range(rTake1, rTake2).Resize(rTake2.Rows.Count, 3).Select _
Destination:=Sheets("Duplicates").Range("A1")

End sub

Dave

OzGrid Business Applications

Posted by Dave Hawley on May 14, 2001 2:22 PM

Hi A.R

Here is some code, that I have not tested. It assumes your data is in Columns A:C with Column A having the Company names. It also assumes Column D is empty and you have a sheet called "Duplicates".

Sub CopyDuplicates()
'Written by OzGrid Business Applications
'www.ozgrid.com

Dim rAllRows As Range
Dim rTake1 As Range
Dim rTake2 As Range

Set rAllRows = Range("A2", Range("A65536").End(xlUp))

rAllRows.Offset(0, 3).FormulaR1C1 = _
"=IF(COUNTIF(C1,RC[-3])>1,1,""no"")"

Set rTake1 = Range("D2:D10000").SpecialCells _
(xlCellTypeFormulas, xlNumbers).Offset(0, -3)
Set rTake2 = Range("D10001", Range("D65536").End(xlUp)).SpecialCells _
(xlCellTypeFormulas, xlNumbers).Offset(0, -2)

Range(rTake1, rTake2).Resize(rTake2.Rows.Count, 3).Copy _
Destination:=Sheets("Duplicates").Range("A1")
End Sub

Dave

OzGrid Business Applications

Posted by Dave Hawley on May 14, 2001 2:27 PM

Ignore the one directly above here.

OzGrid Business Applications