Row deletion..!! Reverse case...

[mchilapur]

Hello All,
Greetings for the day.

I have an unique scenario. Please help me with the VBA code.
Suppose i have below list and i will set the criteria of part of the string, like 'P' and 'B'. I need a VBA code to RETAIN all the rows which has this string (i;e 'P' and 'B') as their cell values and delete which doesn't contain them.
I simple words, i want to retain 'APPLE, 'Boll', and 'Zebra' rows (Because it contains either of the string 'P' and 'B') and delete 'Tree' rows (Because it doesn't contain any of the string 'P' and 'B').

Could you please provide me VBA code this situation.?

Apple	Apple	Apple
Apple	Apple	Apple
Apple	Apple	Apple
Boll	Boll	Boll
Boll	Boll	Boll
Boll	Boll	Boll
Tree	Tree	Tree
Tree	Tree	Tree
Tree	Tree	Tree
Tree	Tree	Tree
Tree	Tree	Tree
Zebra	Zebra	Zebra
Zebra	Zebra	Zebra
Zebra	Zebra	Zebra
Zebra	Zebra	Zebra

[ashleyuk1984]

Here's my take on it mate.

Sub Tree()
    Dim LastRow As Long
    Dim x As Long
     
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
     
    For x = 1 To LastRow - 1
        If InStr(1, Range("A" & x).Value, "p") Or InStr(1, Range("A" & x).Value, "b") Or InStr(1, Range("A" & x).Value, "P") Or InStr(1, Range("A" & x).Value, "B") Then
        Else
        Range("A" & x).EntireRow.ClearContents
        End If
    Next x
    
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


End Sub

[mchilapur]

Thanks for the code..Works perfectly as per my requirement.
Another simple question, is it possible give all the string vales in one set??
Because I have about 20 such strings (like 'P' & 'B').
If I modify your code to 20+ of strings, then code will be too long..

Plz suggest.

Thanks for all ur support..

[mchilapur]

Also plz provide me a code to insert some msgbox if nothing is found to delete.
Thanks.

[westconn1]

are the 3 (or more) columns always the same (as your sample)?
or do you need to check multiple columns?

Sub Tree() 
    Dim LastRow As Long 
    Dim x As Long 
     
    LastRow = Range("A" & Rows.Count).End(xlUp).Row 
   chrstofind =  "pb"    ' change to suit
   set rowstodel = range("a" & lastrow + 1)
    For x = 1 To LastRow - 1
       for c = 1 to len(chrstofind)
        If InStr(1, Range("A" & x).Value, mid(chrstofind, c, 1), vbTextCompare) > 0 Then 
       
           fnd = true
           exit for
        End If 
      next c
       if not fnd then 
        del = true
        set rowstodel = union(rowstodel, range("a" & x))
       else
        fnd = false
       end if
    Next x 
     
   if del then
    rowstodel.entirerow.delete
   else
     msgbox "all rows contain one of the values, nothing deleted"
   end if
     
     
End Sub

i have just modified the code posted above, not tested
if you require to find strings longer than a single character, you wound need to use an array, rather than mid

[mchilapur]

Plz chk the Attched file.User will enter the values as shown in sheet1.
I need the VBA code to retain the rows in 2nd sheets as the combination of values from sheet1 and delete remaining rows.

VBA code must take the string values directly from sheet1.

Thanks for all your help my friend.

[mchilapur]

Finally I need rows with 0G, R 1, GB GD GM GN GW GX values in it.

[westconn1]

try this rewrite

Set workon = Sheets("work on")
Set sinput = Sheets("InPut Data & Macro's")

Dim myinput()
ReDim myinput(38)
cnt = 0
For Each cel In sinput.Range("e3:g16")
    If Not IsEmpty(cel) Then myinput(cnt) = cel:    cnt = cnt + 1
Next
ReDim Preserve myinput(cnt - 1)
Set rowstodel = workon.Range("a" & lastrow + 1)
lrow = workon.Cells(workon.Rows.Count, 1).End(xlUp).Row
For Each cel In workon.Range("a2:a" & lrow)
    For Each c In myinput
        If InStr(1, cel, c, vbTextCompare) > 0 Then
            fnd = True
            Exit For
        End If
    Next
    If Not fnd Then
        del = True
        Set rowstodel = Union(rowstodel, cel)
        Else
        fnd = False
    End If
Next
If del Then
    rowstodel.EntireRow.Delete
    Else
    MsgBox "all rows contain one of the values, nothing deleted"
End If

[mchilapur]

Thanks for reply, but it doesn't delete all the values.
Still rows with 0 will remain and also rows with GGGHHJ, PQPRPT, GRGSGT are not deleted.
And also top header row is deleted.

Could plz re - write code?
Is it not possible to look the values in individual columns separately.??

Regards
Madvesh

[westconn1]

Is it not possible to look the values in individual columns separately.??

ok, i only saw column A to match, i did ask in post #5

or do you need to check multiple columns?

i will look tomorrow, maybe ADO will be the simplest solution

[westconn1]

try
change this line

If InStr(1, cel, c, vbTextCompare) > 0 or InStr(1, cel.offset(10), c, vbTextCompare) > 0 or InStr(1, cel.offset(14), c, vbTextCompare) > 0Then

on rereading i would believe this also is not what you want
you only want rows where all 3 columns match a value in column in other sheet?

[mchilapur]

Yes..This is also not as per my requirement.
I want rows with 0G--> R,1--> GB, GD, GM, GN, GW, GX content in combination.
In the excel file which I have provided, I found only 2 such rows to match this criteria (1st row and 5th row).

Plz check and revert back..I am waiting with fingers crossed.
And ha, sorry for late response.

[mchilapur]

Can anyone plz modify the above code to not to delete the header row (Top row).??
Thanks

[westconn1]

i am still working to get the correct result, but it is taking time

[mchilapur]

Ok...But I am planning to create 3 different macro's one for each column.
If I delete each in sequence, I will definately land with my end result.
Now the only problem is your first code deletes the top header row.If you could please modify the code and stop deleting this topmost row, then I think we are thruough this issue.
I know you are working to compare all the data in one shot, thanks for that, but untill
then plz modify the above to not to delete top row.
I will modify it further with other columns.

Thanks my friend.
Madvesh c

[westconn1]

try this version, at least the headers stay

Set workon = Sheets("work on")
Set sinput = Sheets("InPut Data & Macro's")
 
lrow = workon.Cells(workon.Rows.Count, 1).End(xlUp).Row
Set rowstodel = workon.Range("a" & lrow + 1)
For Each cel In workon.Range("a2:a" & lrow)
    For Each c In sinput.Range("e3:e16")
        If IsEmpty(c) Then Exit For
        If InStr(1, cel, c, vbTextCompare) > 0 Then
            For Each d In sinput.Range("f3:f16")
                If IsEmpty(d) Then Exit For
                If InStr(1, cel.Offset(, 10), d, vbTextCompare) > 0 Then
                    For Each e In sinput.Range("g3:g16")
                        If IsEmpty(e) Then Exit For
                        If InStr(1, cel.Offset(, 14), e, vbTextCompare) > 0 Then
                            fnd = True
                            Exit For
                        End If
                    Next e
                    If fnd Then Exit For
                End If
            Next d
            If fnd Then Exit For
        End If
    Next c
    If Not fnd Then
        del = True
        Set rowstodel = Union(rowstodel, cel)
    Else
        fnd = False
    End If
Next cel
If del Then
    rowstodel.EntireRow.Delete
Else
    MsgBox "all rows contain one of the values, nothing deleted"
End If

[mchilapur]

Thank you very much my friend..It works as per my requirement...Hand off to your logic and intelligence...

Thanks again..!!

Regards,
Madvesh

[westconn1]

pls mark thread resolved

[mchilapur]

Today i was testing your code in all the possible ways...I have small one more small concern, while comparing the columns, seems your code deletes if any of the cell value is empty..Could you plz modify the code to ignore the blank cells...? Means rows with blanks and input values must remain...Rest must be deleted..

[westconn1]

If InStr(1, cel.Offset(, 14), e, vbTextCompare) > 0 or isempty(cel.offset(, 14)) Then

change in 3 places where instr, use the same offset as in the instr