PDA

View Full Version : [SOLVED] Row deletion..!! Reverse case...



mchilapur
05-23-2014, 10:35 AM
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
05-23-2014, 12:13 PM
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
05-23-2014, 10:56 PM
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
05-23-2014, 11:26 PM
Also plz provide me a code to insert some msgbox if nothing is found to delete.
Thanks.

westconn1
05-24-2014, 01:34 AM
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
05-24-2014, 03:07 AM
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
05-24-2014, 03:10 AM
Finally I need rows with 0G, R 1, GB GD GM GN GW GX values in it.

westconn1
05-24-2014, 04:56 AM
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
05-24-2014, 05:41 AM
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
05-24-2014, 06:30 AM
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
05-24-2014, 03:29 PM
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
05-25-2014, 07:35 AM
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
05-26-2014, 08:50 PM
Can anyone plz modify the above code to not to delete the header row (Top row).??
Thanks

westconn1
05-27-2014, 01:30 AM
i am still working to get the correct result, but it is taking time

mchilapur
05-27-2014, 01:41 AM
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
05-27-2014, 03:19 AM
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
05-27-2014, 08:57 AM
Thank you very much my friend..It works as per my requirement...Hand off to your logic and intelligence...

Thanks again..!!

Regards,
Madvesh

westconn1
05-27-2014, 02:25 PM
pls mark thread resolved

mchilapur
05-27-2014, 11:22 PM
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
05-28-2014, 03:02 AM
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

mchilapur
05-28-2014, 05:30 AM
Thanks for all your support..:) Good day..

mchilapur
05-28-2014, 10:13 PM
Hi...Plz chk the attached file.I have modified ur code slightly for 4 criteria's to update the things in 2nd sheet.
As per my understanding on this code, it must not delete any rows from 2nd sheet.
Because, 'PP' is available in all cells of D:'D,16 is available in all cells of C:C
in Q:Q either cells have '1' or are blanks and in R:R either cells have 'MP' or are blanks.

So overall it must not delete any(Msg box must pop up)..Am I right..? But when u run the program, it does and only 4 rows are left along with header..
Plz check the code where I have done mistake in modifying it.

Thanks for ur help.Plz post the new code..:)

westconn1
05-29-2014, 03:59 AM
the reason the code fails is that cells in column Q are not empty (i did not check other columns), they have character count of 1, presumably a space
try changing code to

If InStr(1, cel.Offset(, 16), e, vbTextCompare) > 0 Or Len(Trim(cel.Offset(, 16))) = 0 Then

mchilapur
05-29-2014, 05:51 AM
Haan...You are right..!! :) Thanks..Now new code works...:)
Good day boss...