Delete Duplicate Rows??????

  • Thread starter Thread starter Malcolm
  • Start date Start date
M

Malcolm

Hi

If I have a column of 1500 ID numbers and within that
column some of the numbers are repeated, is there a way of
writing a macro to delete the duplicates leaving just one
of each number. I would also like the removed rows to
move up so there are no spaces between the numbers.

Kind regards

Malcolm
 
Malcolm,

2 ways, a macro and a non-macro

1. Non-macro

One way.

- sort the data
- add a column to test for duplicates by a formula, e.g. in B2 down put
=IF(COUNTIF($A$1:A,A1)>1,"Y","")
- use Autofilter on column B and select the Y's
- delete the rows showing
- clear autofilter

2. Macro

uses same principle, but does it in VBA

Function filterData(sh As Worksheet, _
testCell As Range, _
testValue, _
Optional tempCell, _
Optional testFormula)
Dim cRows As Long
Dim rng As Range
Dim iTestCol As Long
Dim iTempCol As Long

If IsMissing(tempCell) Then
Set tempCell = Range("AA1")
End If

If IsMissing(testFormula) Then
testFormula = "=IF(RC" & iTestCol & testValue & ",""Y"" ,"""")"
End If

iTestCol = testCell.Column

iTempCol = tempCell.Column

With sh
cRows = .Cells(.Rows.Count, iTestCol).End(xlUp).Row
'create a test formula
.Cells(1, iTempCol).FormulaR1C1 = testFormula
'copy the formula down all rows
.Cells(1, iTempCol).AutoFill Destination:=.Range(.Cells(1,
iTempCol), _
.Cells(cRows, iTempCol))
'insert a blank row for autofilter
.Rows(1).Insert
.Cells(1, iTempCol).Value = "Temp"
Set rng = .Range(.Cells(1, iTempCol), .Cells(cRows + 1, iTempCol))
rng.AutoFilter Field:=1, Criteria1:="Y"

End With

Set filterData = rng.SpecialCells(xlCellTypeVisible)

End Function

Sub test()
Dim rng As Range

Set rng = filterData(Worksheets("Sheet2"), Range("A1"), "Y",
Range("AA1"), "=IF(COUNTIF(R1C1:R[]C[-1],R[]C[-26])>1,""Y"","""")")

rng.EntireRow.Delete

Application.CutCopyMode = False

End Sub

End Sub
 
Back
Top