Find and copy duplicates to new worksheet
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.
--
Regards,
Tom Ogilvy
"Del_F" wrote:
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.
|