delete entire row with condition

[Anna]

I would like to have a macro that scan a column (i.e. column a). Under the
scanned column, the entired row of any duplicate cell will be deleted. (i.e.
cell a5=abc, cell a6, a7=abc, row a6 and a7 will be deleted). Anyone can give
me a big hand?
Thank you so much.

 

[JLGWhiz]

If the file is sorted on column A so that all duplicates are grouped, then:

Sub dups()
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
If sh.Cells(i, 1) = sh.Cells(i - 1, 1) Then
Rows(i).Delete
End If
Next
End Sub

The file m8ust be sorted first for the macro to work.

 

[Jacob Skaria]

Hi Anna

Is the column sorted. The below macro will work even if ColA is sorted or
not...Try and feedback

Sub DeleteRows()
Dim lngRow As Long
For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Columns(1), Range("A" & lngRow)) _

1 Then Rows(lngRow).Delete

Next
End Sub

If this post helps click Yes

 

[Rick Rothstein]

Your example is not entirely clear... what is in a6? Are you saying a5, a6
and a7 all have abc in them? If so, are you then saying to leave the
duplicate in the lowest numbered row alone and to delete all the other
duplicates' rows?

 

[Scossa]

Hi Anna

Is the column sorted. The below macro will work even if ColA is sorted or
not...Try and feedback

Sub DeleteRows()
Dim lngRow As Long
For lngRow = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Columns(1), Range("A" & lngRow)) _> 1 Then Rows(lngRow).Delete

Next
End Sub

Too slow!

In a sheet with 21759 rows but 9829 unique value it takes 244.9
seconds
vs 49.5 seconds of Sub DeleteRows() by Jacob Skaria
and vs 25.3 seconds of my sub DelRow():

'=============================
Sub DelRow()
' by Scossa

Dim rRng As Range
Dim rCella As Range
Dim nCnt1 As Long
Dim nCol As Long
Dim nCnt2 As Long
Dim nLastR As Long
Dim nStart As Double
Dim xlcalc As XlCalculation


With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With

nCol = Selection.Column
nLastR = Cells(Rows.Count, nCol).End(xlUp).Row
Set rRng = ActiveCell.Resize(nLastR, 1)

With rRng
nLastR = .Rows.Count
nCnt2 = 0
Set rCella = .Cells(nLastR, 1)

'count start now
nStart = Timer

For nCnt1 = nLastR To 2 Step -1

If .Cells(nCnt1, 1) = .Cells(nCnt1 - 1, 1) Then
nCnt2 = nCnt2 + 1
Set rCella = rCella.Offset(-1, 0)
Else
With rCella
If nCnt2 > 0 Then
.Offset(1, 0).Resize(nCnt2).EntireRow.Delete
End If
End With
nCnt2 = 0
Set rCella = .Cells(nCnt1 - 1, 1)
End If
Next nCnt1

'count end now
MsgBox "elapsed time: " & Timer - nStart

End With

rRng.Cells(1, 1).Select
Application.ActiveWindow.ScrollRow = 1
Set rRng = Nothing
Set rCella = Nothing

With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With

End Sub
'====================

Bye!
Scossa

 

[Jacob Skaria]

Try setting Calculation to manual and disabling Alerts & Screen updating to
see 49.5 coming down..

If this post helps click Yes

 

[Scossa]

Try setting Calculation to manual and disabling Alerts & Screen updating to
see 49.5 coming down..

Times (244.9 49.5 and 25.3) measured with this
3 sub modified and used for test:


Sub DeleteRows()
'by Jacob Skaria

Dim nStart As Double
Dim lngRow As Long
Dim nCol As Long
Dim xlcalc As XlCalculation

With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With
nCol = Selection.Column
nStart = Timer
For lngRow = Cells(Rows.Count, nCol).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Columns(nCol), Cells(lngRow,
nCol)) _

1 Then Rows(lngRow).Delete

Next
MsgBox "elapsed time: " & Timer - nStart
Application.StatusBar = False

With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With

End Sub

Sub dups()
' by JLGWhiz

Dim lr As Long, i As Long, sh As Worksheet
Dim nCol As Long
Dim nStart As Double
Dim xlcalc As XlCalculation

With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With

Set sh = ActiveSheet
nCol = Selection.Column
lr = sh.Cells(Rows.Count, nCol).End(xlUp).Row

nStart = Timer
For i = lr To 2 Step -1
If sh.Cells(i, nCol) = sh.Cells(i - 1, nCol) Then
Rows(i).Delete
End If
Next
MsgBox "elapsed time: " & Timer - nStart
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With
Set sh = Nothing
End Sub

Sub DelRow()
' by Scossa

Dim rRng As Range
Dim rCella As Range
Dim nCnt1 As Long
Dim nCol As Long
Dim nCnt2 As Long
Dim nLastR As Long
Dim nStart As Double
Dim xlcalc As XlCalculation


With Application
xlcalc = .Calculation
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
.StatusBar = "working ... "
End With

nCol = Selection.Column
nLastR = Cells(Rows.Count, nCol).End(xlUp).Row
Set rRng = ActiveCell.Resize(nLastR, 1)

With rRng
nLastR = .Rows.Count
nCnt2 = 0
Set rCella = .Cells(nLastR, 1)
nStart = Timer
For nCnt1 = nLastR To 2 Step -1

If .Cells(nCnt1, 1) = .Cells(nCnt1 - 1, 1) Then
nCnt2 = nCnt2 + 1
Set rCella = rCella.Offset(-1, 0)
Else
With rCella
If nCnt2 > 0 Then
.Offset(1, 0).Resize(nCnt2).EntireRow.Delete
' Application.StatusBar = "elaborating cells ...
remaining " _
' & nCnt1
End If
End With
nCnt2 = 0
Set rCella = .Cells(nCnt1 - 1, 1)
End If
Next nCnt1
MsgBox "elapsed time: " & Timer - nStart
End With
rRng.Cells(1, 1).Select
Application.ActiveWindow.ScrollRow = 1
Set rRng = Nothing
Set rCella = Nothing

With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlcalc
.StatusBar = False
End With

End Sub


Only for information, not for to polemize.

Bye!
Scossa

 

[Jacob Skaria]

Appreciate that.

Here we dont have much information. There can be better/faster solutions but
again that depends on the requirements. If we are talking about getting into
a unique list out of ColA; try the below..

Sub DeleteRows()
Dim lngLastRow As Long
lngLastRow = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, SearchOrder:=xlRows).Row
Range("A1:A" & lngLastRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("A" & lngLastRow + 1), Unique:=True
Rows("1:" & lngLastRow).Delete
End Sub


If this post helps click Yes