VBA to identify one criteria then delete rows based on another

[PrestoS]

I have some simple VBA that highlights the entire row if fields in a column match a certain criteria, however, I would now like the VBA to look at the cells in another column that have been highlighted and delete the row if the cell contains the same value above or below. See example below, rows in orange have been highlighted based on VBA where values in column 'B' are equal to "User Provided". I now need those cells in column A that have been highlighted in orange and all other cells in column A that have the same value as the cell in column A that has been highlighted to be deleted.

A	B
114	User Provided
114	Non Dom
115	User Provided
115	Non Dom
116	No Alloc
116	Non Dom

<TBODY>
</TBODY>

If the VBA was run on the above you would just be left with the below, all other rows will be deleted

A	B
116	No Alloc
116	Non Dom

<TBODY>
</TBODY>

This is the script I've used to highlight the rows:

Sub orange()
Dim LR As Long, i As Long
LR = Range("L" & Rows.Count).End(xlUp).Row
For i = 1 To LR
With Range("L" & i)
If .Value = "User Provided" Then .EntireRow.Interior.ColorIndex = 45
End With
Next i
End Sub

Thanks!

 

[PrestoS]

Any help / suggestions with this would be much appreciated!

Thanks

 

[Peter_SSs]

Welcome to the MrExcel board!

Assuming there are headings in row 1, try this in a copy of your workbook.
Note that my suggestion has nothing to do with the highlighting.
It does assume that, like your samples, if "User Provided" exists, it is in the first row for that particular column A value. If that is not the case, please provide another representative sample & explanation. Also advise what version of Excel you are using.

Sub Del_Rows()
  Dim rCrit As Range
  
  Application.ScreenUpdating = False
  With Range("A1").CurrentRegion
    Set rCrit = .Offset(, .Columns.Count).Resize(2, 1)
    rCrit.Cells(2, 1).Formula = "=VLOOKUP(A2," & .Address & ",2,0)=""User Provided"""
    .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
    .Offset(1).SpecialCells(xlVisible).Delete Shift:=xlUp
    .Parent.ShowAllData
  End With
  rCrit.ClearContents
  Application.ScreenUpdating = True
End Sub

 

[PrestoS]

Hi Peter

Thanks for the response. I'm using excel 2010, I dont think your suggestion quite works, the user provided part could be above or below the column A value. Dont seem to be able to add excel doc through URL option, have tried to show below. First table is how is now, but with User Provided rows highlighted. Second table is what it should change to. So both rows with 114 in are deleted because of the 'user provided' value in B. Similarly all rows with 115, 116 and 118 in are deleted because they too have an association to 'user provided'

What would be best though would be if, the rows were moved onto a new sheet instead of being deleted, is this much of a change to the code?

A	B
114	User Provided
114	Non Dominant
115	User Provided
115	Non Dominant
116	User Provided
116	Non Dominant
116	Non Dominant
117	No Allocation
117	Non Dominant
117	No Allocation
117	No Allocation
118	Non Dominant
118	User Provided

<TBODY>
</TBODY>

A	B
117	Non Dominant
117	No Allocation
117	No Allocation
117	No Allocation

<TBODY>
</TBODY>

Many thanks

 

[Peter_SSs]

... I dont think your suggestion quite works, the user provided part could be above or below the column A value.

Yes, I did say that my suggestion was based on ...

It does assume that, like your samples, if "User Provided" exists, it is in the first row for that particular column A value.

So the change required to do the originally requested task would be to simply change the formula line in my code to

rCrit.Cells(2, 1).Formula = "=COUNTIFS(" & .Columns(1).Address & ",A2," & .Columns(2).Address & ",""User Provided"")>0"

It still does also require that there are headings in row 1 as I stated in my previous post.

What would be best though would be if, the rows were moved onto a new sheet instead of being deleted, is this much of a change to the code?

Try this

Sub Move_Rows()
  Dim rCrit As Range
  Dim wsData As Worksheet, wsNew As Worksheet
  
  Application.ScreenUpdating = False
  Set wsData = ActiveSheet
  Sheets.Add After:=wsData
  Set wsNew = ActiveSheet
  With wsData.Range("A1").CurrentRegion
    Set rCrit = .Offset(, .Columns.Count).Resize(2, 1)
    rCrit.Cells(2, 1).Formula = "=COUNTIFS(" & .Columns(1).Address & ",A2," & .Columns(2).Address & ",""User Provided"")>0"
    .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
    .SpecialCells(xlVisible).Copy wsNew.Range("A1")
    .Offset(1).SpecialCells(xlVisible).Delete Shift:=xlUp
  End With
  wsData.ShowAllData
  wsData.Activate
  rCrit.ClearContents
  Application.ScreenUpdating = True
End Sub

Dont seem to be able to add excel doc

No, but see my signature block for some ways to show small screen shots. You can test them out in the Test Here forum.

 

[PrestoS]

Works a treat! Thanks very much for your help

 

[Peter_SSs]

Works a treat! Thanks very much for your help

Glad to help. Thanks for letting us know how it went.