Delete for 10000 rows if the item contains the same value for two adjacent cells

[KalilMe]

Hi
I want to delete entire row for any item in column B contains the same values for adjacent cells into columns C,D .
I have about 10000 rows in my file

color.xlsm
	A	B	C	D
1	ITEM	BR	PUR	SALES
2	1	VEG TOMATO AA1	22	300
3	2	VEG ONION AA1	6	120
4	3	FR BANANA TTQ1	300	20
5	4	FR BANANA MNB1	200
6	5	VEG TOMATO AA2	339	339
7	6	VEG ONION AA2		50
8	7	FR BANANA TTQ2	200	100
9	8	FR BANANA MNB2	20	10
10	9	VEG TOMATO AA3	10	10
SHM

should be

color.xlsm
	A	B	C	D
1	ITEM	BR	PUR	SALES
2	1	VEG TOMATO AA1	22	300
3	2	VEG ONION AA1	6	120
4	3	FR BANANA TTQ1	300	20
5	4	FR BANANA MNB1	200
6	5	VEG ONION AA2		50
7	6	FR BANANA TTQ2	200	100
8	7	FR BANANA MNB2	20	10
OUTCOME

please just see rows 6,10 before and after

 

[Peter_SSs]

You may see some shorter codes but this one should be very fast for your 10,000 rows

Sub Del_Matches()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  a = Range("C2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = a(i, 2) Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[bebo021999]

I have tested with 10,000 rows and came the results immerdiately

Option Explicit
Sub del()
Dim lr&
lr = Cells(Rows.Count, "B").End(xlUp).Row
Range("A2:A" & lr).Value = Evaluate(1 & "/(" & Range("C2:C" & lr).Address & "-" & Range("D2:D" & lr).Address & ")")
On Error Resume Next
Range("A2:A" & lr).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
lr = Cells(Rows.Count, "B").End(xlUp).Row
Range("A2:A" & lr).Value = Evaluate("=row(1:" & lr - 1 & ")")
End Sub

 

[Peter_SSs]

I have tested with 10,000 rows and came the results immerdiately

It is all relative I guess and depend on machines, how many rows to delete and in how many disjoint areas. Also if the data involves formulas that have to recalculate.
For my testing on identical data, though both were 'fairly' fast yours took just over 25 times as long as mine (1.055 secs v 0.039 secs)

I did note that your code re-numbers column A as shown in post #1 but since that wasn't specifically mentioned in the request I didn't do it, but of course that could easily be added.

 

[jolivanes]

Another possibility to try (have not timed it).
Change references, like Sheet names and Ranges, as required.

Sub Maybe_So()
Dim oldArr, NewArr, i As Long, j As Long, k As Long
oldArr = Sheets("Sheet2").Range("A2:D" & Sheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row).Value
ReDim NewArr(1 To UBound(oldArr), 1 To 4)
k = 0
    For i = LBound(oldArr) To UBound(oldArr)
        If oldArr(i, 3) <> oldArr(i, 4) Then
        k = k + 1
        NewArr(k, 1) = k
            For j = 2 To 4
                NewArr(k, j) = oldArr(i, j)
            Next j
        End If
    Next i
Sheets("Sheet2").Cells(2, 1).Resize(UBound(NewArr), 4) = NewArr
End Sub

And it re-numbers Column A as shown in Post #1, 2nd Picture (tongue firmly in cheek)

 

[Alex Blakenburg]

@jolivanes, I thought it was interesting that your code did not reset the UsedRange to the size of the new data set.
This might be an issue if there are a large number of rows being deleted or if subsequent code relies on the UsedRange,

It seems that the formatting not being cleared from the empty rows is the culprit.

Adding the below 2 lines to the bottom of your code seems to resolve the issue.

Sheets("Sheet2").Cells(2 + k, 1).Resize(UBound(NewArr) - k, 4).ClearFormats
Sheets("Sheet2").UsedRange

 

[jolivanes]

@Alex Blakenburg
I neglected to check that and I thank you for checking that and also rectifying it.
Thanks & Regards

 

[KalilMe]

first sorry about delaying for you , that's because of test for each code individually and see the discussion among you .
second thanks guys for all of codes
@Peter_SSs fantastic ! I tested your code gives running speed 0.16 sec

I did note that your code re-numbers column A as shown in post #1 but since that wasn't specifically mentioned in the request I didn't do it, but of course that could easily be added.

sorry if I don't mentioned that. I thought the picture can be clear. yes shoud re-numbers column A as shown in post #1
I want showing data in second sheet with keep the orginal data in first sheet . I try modifying in this line

    With sheets("outcome").Range("A2").Resize(UBound(a), nc)

but doesn't work , also somtimes gives error block variable in this line

  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1

seem the first sheet should be active , sometimes I select sheet2 accidentally . I hope fixing this problem

 

[KalilMe]

@bebo021999 great without loop !
you have very slight advantage in speed with comparison Peter's code . it gives 0.15
so I want showing data in second sheet with keep the orginal data in first sheet .

 

[KalilMe]

@jolivanes good work ! gives running speed 0.210
thanks for that