delete row based on criteria

D

davide128

Board Regular
Joined
May 12, 2010
Messages
58
Hi I have the following code below which I like because it asks the user for the column they want to search on and what to search for..Problem is there are like 200 Thousand rows and that code seems to just hang..Is there a more efficient way to delete rows lets say that contain the number 1 in column B and delete it if does and of course shift rows up if it does..

Code: 
[COLOR=blue]Option Explicit[/COLOR] 
 
[COLOR=blue]Sub[/COLOR] KillRows() 
     
    [COLOR=blue]Dim[/COLOR] MyRange [COLOR=blue]As[/COLOR] Range, DelRange [COLOR=blue]As[/COLOR] Range, C [COLOR=blue]As[/COLOR] Range 
    [COLOR=blue]Dim[/COLOR] MatchString [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], SearchColumn [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], ActiveColumn [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR] 
    [COLOR=blue]Dim[/COLOR] FirstAddress [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], NullCheck [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR] 
    [COLOR=blue]Dim[/COLOR] AC 
     
     [COLOR=darkgreen]'Extract active column as text[/COLOR]
    AC = Split(ActiveCell.EntireColumn.Address(, [COLOR=blue]False[/COLOR]), ":") 
    ActiveColumn = AC(0) 
     
    SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Delete Code", ActiveColumn) 
     
    [COLOR=blue]On Error Resume Next[/COLOR] 
    [COLOR=blue]Set[/COLOR] MyRange = Columns(SearchColumn) 
    [COLOR=blue]On Error Goto[/COLOR] 0 
     
     [COLOR=darkgreen]'If an invalid range is entered then exit[/COLOR]
    [COLOR=blue]If[/COLOR] MyRange [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] Exit [COLOR=blue]Sub[/COLOR] 
     
    MatchString = InputBox("Enter Search string", "Row Delete Code", ActiveCell.Value) 
    [COLOR=blue]If[/COLOR] MatchString = "" [COLOR=blue]Then[/COLOR] 
        NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _ 
        "Type Yes to do so, else code will exit", "Caution", "No") 
        [COLOR=blue]If[/COLOR] NullCheck <> "Yes" [COLOR=blue]Then[/COLOR] Exit [COLOR=blue]Sub[/COLOR] 
    [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
     
    Application.ScreenUpdating = [COLOR=blue]False[/COLOR] 
     
     [COLOR=darkgreen]'to match the WHOLE text string[/COLOR]
    [COLOR=blue]Set[/COLOR] C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole) 
     [COLOR=darkgreen]'to match a PARTIAL text string use this line[/COLOR]
     [COLOR=darkgreen]'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)[/COLOR]
     [COLOR=darkgreen]'to match the case and of a WHOLE text string[/COLOR]
     [COLOR=darkgreen]'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)[/COLOR]
     
    [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] C [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] 
        [COLOR=blue]Set[/COLOR] DelRange = C 
        FirstAddress = C.Address 
        [COLOR=blue]Do[/COLOR] 
            [COLOR=blue]Set[/COLOR] C = MyRange.FindNext(C) 
            [COLOR=blue]Set[/COLOR] DelRange = Union(DelRange, C) 
        [COLOR=blue]Loop[/COLOR] [COLOR=blue]While[/COLOR] FirstAddress <> C.Address 
    [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
     
     [COLOR=darkgreen]'If there are valid matches then delete the rows[/COLOR]
    [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] DelRange [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] DelRange.EntireRow.Delete 
     
    Application.ScreenUpdating = [COLOR=blue]True[/COLOR] 
     
[COLOR=blue]End Sub[/COLOR]
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
Sort by date Sort by votes
davide128 said:
Hi I have the following code below which I like because it asks the user for the column they want to search on and what to search for..Problem is there are like 200 Thousand rows and that code seems to just hang..Is there a more efficient way to delete rows lets say that contain the number 1 in column B and delete it if does and of course shift rows up if it does..

Code: 
[COLOR=blue]Option Explicit[/COLOR] 
 
[COLOR=blue]Sub[/COLOR] KillRows() 
     
    [COLOR=blue]Dim[/COLOR] MyRange [COLOR=blue]As[/COLOR] Range, DelRange [COLOR=blue]As[/COLOR] Range, C [COLOR=blue]As[/COLOR] Range 
    [COLOR=blue]Dim[/COLOR] MatchString [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], SearchColumn [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], ActiveColumn [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR] 
    [COLOR=blue]Dim[/COLOR] FirstAddress [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR], NullCheck [COLOR=blue]As[/COLOR] [COLOR=blue]String[/COLOR] 
    [COLOR=blue]Dim[/COLOR] AC 
     
     [COLOR=darkgreen]'Extract active column as text[/COLOR]
    AC = Split(ActiveCell.EntireColumn.Address(, [COLOR=blue]False[/COLOR]), ":") 
    ActiveColumn = AC(0) 
     
    SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Delete Code", ActiveColumn) 
     
    [COLOR=blue]On Error Resume Next[/COLOR] 
    [COLOR=blue]Set[/COLOR] MyRange = Columns(SearchColumn) 
    [COLOR=blue]On Error Goto[/COLOR] 0 
     
     [COLOR=darkgreen]'If an invalid range is entered then exit[/COLOR]
    [COLOR=blue]If[/COLOR] MyRange [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] Exit [COLOR=blue]Sub[/COLOR] 
     
    MatchString = InputBox("Enter Search string", "Row Delete Code", ActiveCell.Value) 
    [COLOR=blue]If[/COLOR] MatchString = "" [COLOR=blue]Then[/COLOR] 
        NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _ 
        "Type Yes to do so, else code will exit", "Caution", "No") 
        [COLOR=blue]If[/COLOR] NullCheck <> "Yes" [COLOR=blue]Then[/COLOR] Exit [COLOR=blue]Sub[/COLOR] 
    [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
     
    Application.ScreenUpdating = [COLOR=blue]False[/COLOR] 
     
     [COLOR=darkgreen]'to match the WHOLE text string[/COLOR]
    [COLOR=blue]Set[/COLOR] C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole) 
     [COLOR=darkgreen]'to match a PARTIAL text string use this line[/COLOR]
     [COLOR=darkgreen]'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)[/COLOR]
     [COLOR=darkgreen]'to match the case and of a WHOLE text string[/COLOR]
     [COLOR=darkgreen]'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)[/COLOR]
     
    [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] C [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] 
        [COLOR=blue]Set[/COLOR] DelRange = C 
        FirstAddress = C.Address 
        [COLOR=blue]Do[/COLOR] 
            [COLOR=blue]Set[/COLOR] C = MyRange.FindNext(C) 
            [COLOR=blue]Set[/COLOR] DelRange = Union(DelRange, C) 
        [COLOR=blue]Loop[/COLOR] [COLOR=blue]While[/COLOR] FirstAddress <> C.Address 
    [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
     
     [COLOR=darkgreen]'If there are valid matches then delete the rows[/COLOR]
    [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] DelRange [COLOR=blue]Is[/COLOR] [COLOR=blue]Nothing[/COLOR] [COLOR=blue]Then[/COLOR] DelRange.EntireRow.Delete 
     
    Application.ScreenUpdating = [COLOR=blue]True[/COLOR] 
     
[COLOR=blue]End Sub[/COLOR]
Click to expand...

This would simply "delete rows that contain the number 1 in column B and shift rows up.
Rich (BB code): 
Sub davide128()
Dim i As Long
Dim lr As Long

Application.ScreenUpdating = False

lr = Cells(Rows.Count, 2).End(xlUp).Row

Range("B2:B" & lr).AutoFilter Field:=1, Criteria1:="1"
Range("B2:B" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlp
Columns("B:B").AutoFilter

Application.ScreenUpdating = True


End Sub

Not as sophisticated as what you have now.
 
Upvote 0
davide128 said:
Looks like it deleted everything else and kept all that contain "1" is it backwards?
Click to expand...

No it shouldn't. It was tested with 1. It worked for me. I noticed an error with the code.

Change this:

Range("B2:B" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlp

to

Range("B2:B" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlUp
 
Upvote 0
davide128 said:
Is there a more efficient way to delete rows lets say that contain the number 1 in column B and delete it if does and of course shift rows up if it does..
Click to expand...
Try this (based on mirabeau's suggestion in post #9 in this thread.)

Assumption is that there are headings in row 1 and we can use row 1 to determine the extent of columns used.

Test in a copy of your workbook.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Del_Rows()<br>    <SPAN style="color:#00007F">Dim</SPAN> LR <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, LC <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, rws <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> aCol, tmp<br>    <br>    <SPAN style="color:#00007F">Const</SPAN> LookForVal <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "1" <SPAN style="color:#007F00">'<- Value you are looking for</SPAN><br>                                <br>    LR = Range("B" & Rows.Count).End(xlUp).Row<br>    LC = Cells(1, Columns.Count).End(xlToLeft).Column<br>    aCol = Range("B2:B" & LR).Value<br>    <SPAN style="color:#00007F">ReDim</SPAN> tmp(1 <SPAN style="color:#00007F">To</SPAN> LR - 1, 1 <SPAN style="color:#00007F">To</SPAN> 1)<br>    <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> LR - 1<br>        <SPAN style="color:#00007F">If</SPAN> aCol(i, 1) = LookForVal <SPAN style="color:#00007F">Then</SPAN><br>            rws = rws + 1<br>            tmp(i, 1) = 1<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    <SPAN style="color:#00007F">If</SPAN> rws > 0 <SPAN style="color:#00007F">Then</SPAN><br>        Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>        Columns("A").Insert<br>        <SPAN style="color:#00007F">With</SPAN> Range("A2").Resize(LR - 1)<br>            .Value = tmp<br>            .Resize(, LC + 1).Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo<br>            .Resize(rws).EntireRow.Delete<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        Columns("A").Delete<br>        Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br></FONT>
 
Upvote 0
davide128 said:
I get Run-time error 1004 Microsoft cannot create the data range reference because it's too complex.
Click to expand...

Not the best but, maybe?

Code: 
Sub davide128()

Dim r As Long
Dim x As Long
Dim i As Long
Dim lr As Long

Application.ScreenUpdating = False

r = 10000

lr = Cells(r, 2).End(xlUp).Row

x = 2

On Error Resume Next

Do While Range("B" & lr).Offset(1, 0) <> ""

Range(Range("B" & x), Range("B" & lr)).AutoFilter Field:=1, Criteria1:="1"
Range(Range("B" & x), Range("B" & lr)).SpecialCells(xlCellTypeVisible).EntireRow.Delete shift:=xlp
Columns("B:B").AutoFilter

x = x + r - 1

lr = lr + lr


Loop

Application.ScreenUpdating = True


End Sub
 
Upvote 0
I think Excel is just not good at handling 200K rows of data..Macro has been running for like 30 minutes now..I think I need to tell the person giving me the data to handle it on his end...(database end)
 
Upvote 0
John Davis said:
Not the best but, maybe?
Click to expand...
John, I think that could have some strange results! To demonstrate one such thing, change your r=10000 to r=10 and try it on a sheet with headings in row 1 and data (some 1s and some other values) in B1:B12
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Adapt VBA code where "Find" is equal to a MID function (etc)
Replies
6
Views
300
GTS
G
C
  • Question Question
Using pattern searches with a variable to find the correct values
2
Replies
10
Views
258
chazrab
C
C
  • Question Question
How would i use the FIND method with the AND operator to find any two words in a sheet cell, i.e., "understanding" AND "heart"
2
Replies
11
Views
552
Trebor76
T
N
  • Question Question
AutoFilter Field Macro Returns a Header Row only
2
Replies
11
Views
208
MARK858
MARK858
I
  • Solved
Also have the row number shown in Listbox on userform advice
Replies
7
Views
117
NoSparks
N

Forum statistics

Threads
1,224,551
Messages
6,179,476
Members
452,915
Latest member
hannnahheileen

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top