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

 

[jolivanes]

Thanks for the updates. Appreciated.

 

[Peter_SSs]

so I want showing data in second sheet with keep the orginal data in first sheet .

Try this then. I have assumed that sheet 'OUTCOME' as shown in post 1 does not already exist in the workbook.
This code will retain any formatting from the retained cells but would replace any formulas with their results.

Sub FilterToNewSheet()
  Dim rData As Range, rCrit As Range
  
  With Sheets("SHM")
    Set rCrit = .Range("Z1:Z2")
    Set rData = .Range("A1:D" & .Range("A" & Rows.Count).End(xlUp).Row)
  End With
  rCrit.Cells(2).Formula = "=C2<>D2"
  Application.ScreenUpdating = False
  Sheets.Add(After:=Sheets("SHM")).Name = "OUTCOME"
  With Sheets("OUTCOME")
    rData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCrit, CopyToRange:=.Range("A1"), Unique:=False
    rCrit.ClearContents
    With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
      .Value = Evaluate("row(" & .Address & ")-1")
    End With
    .UsedRange.Columns.AutoFit
  End With
  Applicatio

 

[KalilMe]

@Peter_SSs thanks

truly first code is much better than last . the last gives me 1.08 despite of the last code using advanced filter , strange!!

this is not big problem , but I need fixing error if I run the macro continuously will give error about shee name outcome is already existed . could be updated data in sheet outcome based on update sheet SHM without shows error after create sheet OUTPUT

 

[Peter_SSs]

truly first code is much better than last .

Not sure how the first code can be better when it doesn't move the results to a new sheet like you want?

if I run the macro continuously will give error about shee name outcome is already existed . could be updated data in sheet outcome based on update sheet SHM without shows error after create sheet OUTPUT

What do you want to happen if the code is run repeatedly?
- Delete the OUTPUT sheet if it exists and put the new data on a new OUTPUT sheet?
- Put the new data on a different new sheet each time but keep the old ones too?
- Append the new data at the bottom of the existing OUTPUT sheet? If you do this, presumably some of the data will get repeated on the OUTPUT sheet.
- Something else? Please give clear details.

 

[KalilMe]

Not sure how the first code can be better when it doesn't move the results to a new sheet like you want?

the same question ask myself. I'm surprised.

- Put the new data on a different new sheet each time but keep the old ones too?

I don't need creating new sheet every time when run the macro . should be in the same sheet has been created . this means to replace data when run the macro should clear data from the first time from sheet OUPUT before bring data from first sheet until doesn't repeat copying data .

 

[Peter_SSs]

Try this

Sub FilterToOUTPUT()
  Dim rData As Range, rCrit As Range
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("OUTPUT").Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
  Sheets.Add(After:=Sheets("SHM")).Name = "OUTPUT"
  With Sheets("SHM")
    Set rCrit = .Range("Z1:Z2")
    Set rData = .Range("A1:D" & .Range("A" & Rows.Count).End(xlUp).Row)
  End With
  rCrit.Cells(2).Formula = "=C2<>D2"
  With Sheets("OUTPUT")
    rData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCrit, CopyToRange:=.Range("A1"), Unique:=False
    rCrit.ClearContents
    With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
      .Value = Evaluate("row(" & .Address & ")-1")
    End With
    .UsedRange.Columns.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

 

[KalilMe]

excellent ! this is what I want .
thank you & of course the other guys for your help

 

[Peter_SSs]

Cheers.