Find and copy duplicates to new worksheet

[Del_F]

Hi,
I have a macro to find and mark duplicated values in a sorted column
of data as follows:

Sub FindDuplicates()
Dim check As String
Dim colName As String
Dim A As Integer
colName = "B"
Range(colName & 1).Select
'loop through first 100 rows
For A = 1 To 100
Range(colName & A).Activate
If ActiveCell.Value = check Then
ActiveCell.Font.Bold = True
Else
End If
check = ActiveCell.Value
Next A
End Sub

I'd like to copy the values from the marked cells (and also the
matching value from the cell above, if possible) to a new worksheet.

I can get the first hit okay by adding this code to the loop:
ActiveCell.EntireRow.Copy
Sheets(2).Select
ActiveSheet.Paste
.... but this breaks things - presumably because I lose the active
cell?

Any suggestions on how I should approach this?

many thanks,

Del.

 

[Guest]

the way to speed up your code and avoid these situations is to resist using
selection, select, and activecell. They are usually not necessary.

Change colNum to point to the column you want to check for duplicates

Sub FindDuplicates()
Dim colNum as String
Dim rng as range, cell as Range
Dim rng1 as Range
colNum = "A"
With Activesheet
set rng = .Range(.Cells(1,colNum), _
.Cells(rows.count,colNum).End(xlup))
End With
for each cell in rng
if application.Countif(rng,cell) > 1 then
if rng1 is nothing then
set rng1 = cell
else
set rng1 = Union(rng1,cell)
end if
end if
Next
If not rng1 is nothing then
rng1.entireRow.Copy Sheets(2).Range("A1")
End if
End Sub

the code worked fine for me. It should be placed in a General Module (in
the VBE, Insert=>Module). It processes the activesheet when you run it.

 

[Del_F]

okay, made some progress:

Sub FindDuplicates()
Dim check As String
Dim colName As String
Dim A As Integer
Dim count As Integer
colName = "B"
count = 1
Range(colName & 1).Select
'loop through first 100 rows
For A = 1 To 100
Range(colName & A).Activate
If ActiveCell.Value = check Then
ActiveCell.Font.Bold = True
ActiveCell.EntireRow.Copy
Destination:=Worksheets("Sheet2").Cells(count, 1)
count = count + 1
Else
End If
check = ActiveCell.Value
Next A
End Sub

Any tips on how to copy both the matched row and the row above (i.e.
the source of the 'check' value) would be welcome!

Many thanks.

 

[Guest]

A solution has been offered. Is there a problem.

 

[Del_F]

Hi Tom,

Your solution works nicely; many thanks. Thanks also for the coding
tips - duly noted!

Del.

 

[Guest]

Hi Tom,
I have a question in regards to the code you posted on finding duplicates?
What would be the best way make the sub use whats in a combobox. In other
words have it search say column 'A' for say 'dog' from the combox selection
list?