delete rows that have a duplicate id keeping the upper row

  • Thread starter Thread starter Bruce Walker
  • Start date Start date
B

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
 
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
 
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
 
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.
 
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.
 
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.
 
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.
 
Back
Top