delete rows that have a duplicate id keeping the upper row

[Bruce Walker]

I neeed a macro that will delte a row based on a duplicate value in column A;
Row col A col B col C
Claim Number DCC Warranty Code
1 0132482B DTYC 03D
2 0137448A 1
3 0141614A 01D
4 0141614A
5 0141614A
6 0143504B 1
7 0154120A DW77 01D
8 0154120A
9 0159953A DWL0 03D
In this example I want to delete rows 4,5, and 8 How might this be
accomlpished? Thanks.
Bruce

 

[Chip Pearson]

Try code like

Sub AAA()
Dim LastRow As Long
Dim RowNdx As Long
Dim N As Long

With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For RowNdx = LastRow To 2 Step -1
N = Application.CountIf( _
Range(Cells(2, "A"), Cells(RowNdx, "A")), _
Cells(RowNdx, "A"))
If N > 1 Then
Rows(RowNdx).Delete
End If
Next RowNdx
End Sub

Cordially,
Chip Pearson
Microsoft Most Valuable Professional,
Excel, 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com



On Wed, 17 Mar 2010 12:57:01 -0700, Bruce Walker <Bruce

 

[JLGWhiz]

Sub DelDupRow() 'if duplicates exists, deletes duplicate rows
Dim lr As Long, sh As Worksheet
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row .
For i = lr To 2 Step -1
With sh
If Cells(i, 1).Value = Cells(i-1, 1).Value Then
Rows(i).Delete
End If
End With
Next
End Sub

 

[Mike H]

Hi,

Ensure your data sheet is the active sheet and try this

Sub delete_Me2()
Dim CopyRange As Range
Dim X as Long, LastRow as long
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For x = 1 To LastRow
If WorksheetFunction.CountIf(Range(Cells(x, 1), _
Cells(x + 1, LastRow)), Cells(x, 1)) > 1 Then
If CopyRange Is Nothing Then
Set CopyRange = Rows(x).EntireRow
Else
Set CopyRange = Union(CopyRange, Rows(x).EntireRow)
End If
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Delete
End If
End Sub
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Mike H]

Ignore this, I missed keep the upper row bit
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Mike H]

That's got it

Sub delete_Me2()
Dim CopyRange As Range
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
For x = LastRow To 2 Step -1
Range(Cells(1, 1), Cells(x - 1, 1)).Select
If WorksheetFunction.CountIf(Range(Cells(1, 1), _
Cells(x - 1, 1)), Cells(x, 1)) > 0 Then
Rows(x).Delete
End If
Next
If Not CopyRange Is Nothing Then
CopyRange.Select
End If
End Sub
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Bruce Walker]

Mike,
Thank you very much (and to all that replied)! It does exactly what I needed
it to do. I have a similar but somewhat more complicated spreadsheet I need a
macro for the same thing, but I am not sure how to explain it without you
being able to see it. Any suggestions? Thanks again.