Delete rows in spreadsheet where cells match some patterns

Question

I have vba code that loops through a large number of records and deletes rows based on criteria. The issue at hand is that it takes far too long to run. I have never actually let it finish because it takes so long (about five minutes puts it around row 700 out of ~250000). Basically, I need to loop through and see if cell contents contain the string template (or some variation as shown in code below) and if so delete that row.

First Attempt

lr = sht.Cells(Rows.Count, 1).End(xlUp).Row 'LastRow For i = lr To 2 Step -1 If sht.Cells(i, 1).Value Like "*template*" Or sht.Cells(i, 1).Value Like "*TEMPLATE*" _ Or sht.Cells(i, 1).Value Like "*Template*" Or _ sht.Cells(i, 3).Value Like "*template*" Or sht.Cells(i, 3).Value Like "*TEMPLATE*" _ Or sht.Cells(i, 3).Value Like "*Template*" Then sht.Cells(i, 1).EntireRow.delete End If Next i

but after This Post on SO, I tried reworking it.

Second Attempt (and currently in use)

Dim delete as Range Set delete = Nothing Set myRange = sht.Range("A2", sht.Cells(lr, 1)) For Each myCell In myRange If myCell.Value Like "*template*" Or myCell.Value Like "*TEMPLATE*" _ Or myCell.Value Like "*Template*" Or myCell.Offset(0, 2).Value Like "*template*" _ Or myCell.Offset(0, 2).Value Like "*TEMPLATE*" _ Or myCell.Offset(0, 2).Value Like "*Template*" Then If Not delete Is Nothing Then Set delete = Union(delete, myCell) Else Set delete = myCell End If End If Next myCell If Not delete Is Nothing Then delete.EntireRow.delete End If

Full Code (You asked for it....)

Public Sub EntitlementReport() Application.ScreenUpdating = False Dim accountBook As Workbook, entitlementsBk As Workbook, groupBk As Workbook Dim wb As Workbook, final As Workbook Dim sht As Worksheet Dim aBkFound As Boolean, eBkFound As Boolean, gBkFound As Boolean aBkFound = False eBkFound = False gBkFound = False Set final = ActiveWorkbook Set sht = final.Sheets(1) For Each wb In Workbooks If wb.name Like "Accounts*" Then Set accountBook = wb aBkFound = True ElseIf wb.name Like "GroupMembership*" Then Set groupBk = wb gBkFound = True ElseIf wb.name Like "UserEntitlements*" Then Set entitlementsBk = wb eBkFound = True End If If aBkFound And gBkFound And eBkFound Then Exit For End If Next wb If Not aBkFound Then MsgBox ("Could not find the Accounts file. Please make sure it is open." & vbNewLine & _ "Exiting procedure.") End End If If Not eBkFound Then MsgBox ("Could not find the UserEntitlements file. Please make sure it is open." & vbNewLine & _ "Exiting procedure.") End End If If Not gBkFound Then MsgBox ("Could not find the GroupMembers file. Please make sure it is open." & vbNewLine & _ "Exiting procedure.") End End If Dim ws As Worksheet For Each ws In final.Worksheets If ws.name = "Entitlements" Or ws.name = "Groups" Or ws.name = "Accounts" Then Application.DisplayAlerts = False ws.delete Application.DisplayAlerts = True End If Next ws final.Sheets.Add after:=final.Sheets(1) ActiveSheet.name = "Entitlements" final.Sheets.Add after:=final.Sheets(1) ActiveSheet.name = "Groups" final.Sheets.Add after:=final.Sheets(1) ActiveSheet.name = "Accounts" sht.Cells.Clear Dim eSht As Worksheet, gSht As Worksheet, aSht As Worksheet Set eSht = final.Sheets("Entitlements") Set gSht = final.Sheets("Groups") Set aSht = final.Sheets("Accounts") Dim lr As Long, lc As Long lr = groupBk.Sheets(1).Cells(Rows.Count, 1).End(xlUp).row lc = groupBk.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column With groupBk.Sheets(1) lr = .Cells(Rows.Count, 1).End(xlUp).row lc = .Cells(1, Columns.Count).End(xlToLeft).Column .Range("A1", .Cells(lr, lc)).Copy End With gSht.Range("A1").PasteSpecial xlPasteAll Application.CutCopyMode = False lr = accountBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).row lc = accountBook.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column With accountBook.Sheets(1) lr = .Cells(Rows.Count, 1).End(xlUp).row lc = .Cells(1, Columns.Count).End(xlToLeft).Column .Range("A1", .Cells(lr, lc)).Copy End With aSht.Range("A1").PasteSpecial xlPasteAll Application.CutCopyMode = False aSht.Range("A1", aSht.Cells(lr, lc)).RemoveDuplicates Columns:=2, header:=xlYes lr = entitlementsBk.Sheets(1).Cells(Rows.Count, 1).End(xlUp).row lc = entitlementsBk.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column With entitlementsBk.Sheets(1) lr = .Cells(Rows.Count, 1).End(xlUp).row lc = .Cells(1, Columns.Count).End(xlToLeft).Column .Range("A1", .Cells(lr, lc)).Copy End With eSht.Range("A1").PasteSpecial xlPasteAll Application.CutCopyMode = False Dim myRange As Range, myCell As Range Set myRange = eSht.Range("A1", eSht.Cells(lr, lc)) For Each myCell In myRange myCell.Value = Replace(myCell.Value, Chr(34), vbNullString) Next myCell Dim sortRange As Range Set sortRange = eSht.Range(eSht.Cells(1, "G"), eSht.Cells(lr, "G")) eSht.Range("G1").AutoFilter eSht.AutoFilter.sort.SortFields.Clear eSht.AutoFilter.sort.SortFields.Add key:=sortRange, SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal With eSht.AutoFilter.sort .header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With eSht.Range("G1").AutoFilter Set sortRange = eSht.Range(eSht.Cells(2, "G"), eSht.Cells(lr, "G")) Set myRange = gSht.Range(gSht.Cells(2, 1), _ gSht.Cells(gSht.Cells(Rows.Count, 1).End(xlUp).row, 1)) Dim nextOpenRow As Long nextOpenRow = 2 For Each myCell In sortRange Set c = myRange.Find(myCell.Offset(0, -2).Value) If Not c Is Nothing Then firstAddress = c.address Do sht.Cells(nextOpenRow, 1).Value = c.Offset(0, 2).Value sht.Cells(nextOpenRow, 2).Value = c.Offset(0, 3).Value & ", " & c.Offset(0, 4).Value sht.Cells(nextOpenRow, 3).Value = myCell.Offset(0, -1).Value sht.Cells(nextOpenRow, 4).Value = myCell.Value sht.Cells(nextOpenRow, 5).Value = myCell.Offset(0, 3).Value sht.Cells(nextOpenRow, 6).Value = myCell.Offset(0, -2).Value nextOpenRow = nextOpenRow + 1 Set c = myRange.FindNext(c) Loop While Not c Is Nothing And c.address <> firstAddress End If Next myCell ' For Each myCell In sortRange ' Set myRange = gSht.Range(gSht.Cells(2, 1), _ ' gSht.Cells(gSht.Cells(Rows.Count, 1).End(xlUp).row, 1)) ' On Error GoTo Finish ' Do ' c = Application.WorksheetFunction.Match(myCell.Offset(0, -2).Value, myRange, 0) ' sht.Cells(nextOpenRow, 1).Value = myRange(c, 1).Offset(0, 2).Value ' sht.Cells(nextOpenRow, 2).Value = myRange(c, 1).Offset(0, 3).Value ' sht.Cells(nextOpenRow, 3).Value = myCell.Offset(0, -1).Value ' sht.Cells(nextOpenRow, 4).Value = myCell.Value ' sht.Cells(nextOpenRow, 5).Value = myCell.Offset(0, 3).Value ' sht.Cells(nextOpenRow, 6).Value = myCell.Offset(0, -2).Value ' nextOpenRow = nextOpenRow + 1 ' Set myRange = myRange.Resize(myRange.Rows.Count - c, 1).Offset(c, 0) ' Loop 'Finish: ' Resume NextCell 'NextCell: ' Next myCell ' ' On Error GoTo 0 sht.Cells(1, 1).Value = "UserID" sht.Cells(1, 2).Value = "User" sht.Cells(1, 3).Value = "System Name" sht.Cells(1, 4).Value = "Account Name" sht.Cells(1, 5).Value = "Policy Name" sht.Cells(1, 6).Value = "Group Name" sht.Cells(1, 7).Value = "Owner Name" lr = sht.Cells(Rows.Count, 1).End(xlUp).row lc = sht.Cells(1, Columns.Count).End(xlToLeft).Column Dim delete As Range On Error Resume Next Set delete = sht.Range(sht.Cells(1, 4), sht.Cells(lr, 4)).SpecialCells(xlCellTypeBlanks) On Error GoTo 0 delete.EntireRow.delete Set delete = Nothing lr = sht.Cells(Rows.Count, 1).End(xlUp).row ' ' For i = lr To 2 Step -1 ' If sht.Cells(i, 1).Value Like "*template*" Or sht.Cells(i, 1).Value Like "*TEMPLATE*" _ ' Or sht.Cells(i, 1).Value Like "*Template*" Or _ ' sht.Cells(i, 3).Value Like "*template*" Or sht.Cells(i, 3).Value Like "*TEMPLATE*" _ ' Or sht.Cells(i, 3).Value Like "*Template*" Then ' sht.Cells(i, 1).EntireRow.delete ' End If ' Next i ' Set myRange = sht.Range("A2", sht.Cells(lr, 1)) For Each myCell In myRange If myCell.Value Like "*template*" Or myCell.Value Like "*TEMPLATE*" _ Or myCell.Value Like "*Template*" Or myCell.Offset(0, 2).Value Like "*template*" _ Or myCell.Offset(0, 2).Value Like "*TEMPLATE*" _ Or myCell.Offset(0, 2).Value Like "*Template*" Then If Not delete Is Nothing Then Set delete = Union(delete, myCell) Else Set delete = myCell End If End If Next myCell If Not delete Is Nothing Then delete.EntireRow.delete End If Set ws = Nothing Set wb = Nothing Set accountBook = Nothing Set entitlementsBk = Nothing Set groupBk = Nothing Set final = Nothing Set eSht = Nothing Set gSht = Nothing Set myRange = Nothing Set myCell = Nothing Set sortRange = Nothing Set delete = Nothing Set c = Nothing Application.ScreenUpdating = True End Sub

Question Is there a better, more efficient way to loop through the large amount of data I have, and delete rows with this criteria?

So if a row contains the string "template" regardless of case, remove it? — Raystafarian
– Raystafarian, Commented Feb 15, 2017 at 16:11
@Raystafarian that is correct. I know that I can change the Comparison Method but I haven't had much practice with that and I am unsure if it would really help anyways. I could be wrong though! — PartyHatPanda
– PartyHatPanda, Commented Feb 15, 2017 at 16:13
Welcome to CR! As you'll find out when you get answers on this site, reviewers comment on every aspect of the code, so more context is always better than a boiled-down snippet - e.g. is that code written in the body of a procedure? What's that procedure named, and how is it being called? Is that all of it or the procedure has other responsibilities? Is Option Explicit specified at the top of the module? — Mathieu Guindon
– Mathieu Guindon, Commented Feb 15, 2017 at 16:20
What you're saying (700 rows in 5 minutes) sounds implausible given the code you've presented. Which almost certainly means there are other things going on that need to be addressed. It would be really useful if you could post all your code and also give us a good overview of your sheets and your data. How much is there? Are there any functions? How does your code get called, from where, and what happens before the delete rows code gets run? Also, how are you determining that it's on row 700 after 5 minutes? — Kaz
– Kaz, Commented Feb 15, 2017 at 16:23
@PartyHatPanda Yes, SO and CR, have different, in fact opposite requirements for useful questions. Over here, more information and context is always better. — Kaz
– Kaz, Commented Feb 15, 2017 at 16:24

Raystafarian · Accepted Answer · 2017-02-15 16:38:27Z

You know what really speeds up vba? ARRAYS! Why do stuff on the sheet when you can do it in an array?

Option Explicit Sub FindTemplate() Dim targetSheet As Worksheet Set targetSheet = Sheet1 Dim lastRow As Long lastRow = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row Dim myData As Variant myData = targetSheet.Range(Cells(1, 1), Cells(lastRow, 3)) Dim myResults As Variant ReDim myResults(1 To lastRow, 1 To 3) Dim resultIndex As Long resultIndex = 1 Dim index As Long For index = LBound(myData) To UBound(myData) If (InStr(1, myData(index, 1), "template", vbTextCompare) > 0) Or (InStr(1, myData(index, 3), "template", vbTextCompare) > 0) Then myResults(resultIndex, 1) = myData(index, 1) myResults(resultIndex, 2) = myData(index, 2) myResults(resultIndex, 3) = myData(index, 3) resultIndex = resultIndex + 1 End If Next targetSheet.UsedRange.Clear targetSheet.Range(Cells(1, 1), Cells(resultIndex, 3)) = myResults End Sub

Kaz · Accepted Answer · 2017-02-15 16:40:32Z

Simple VBA performance testing

The first rule of making code faster is this:

There will be a bottleneck, but until you benchmark your code, you won't know where it is.

Your code is doing about 10 different things. 9 of those things will take only a few seconds. The tenth is taking forever. We need to identify which part of the code is being slow before we can fix it.

In VBA, the simplest way to benchmark your code is to do the following:

Before every "section" (say, the open workbooks section, or the add worksheets section, or the sort data section), add this line:

Debug.Print "Starting Section X" & " - " & Format(Now, "HH:MM:SS")

Where X is some useful description.

Then, after every section, add

Debug.Print "Finished Section X" & " - " & Format(Now, "HH:MM:SS")

Then run your code.

It will very quickly become apparent which section is taking all the time, because it will be the one that started minutes ago and hasn't finished yet.

Once you know which section is the problem, you can ask a focused question (here or elsewhere) about that code to figure out how to make it faster.

Rinse and repeat until your total runtime is as low as you need it to be.

I did use This Timer Code to do something similar. It took a minute to reach the block in question, so this is what leads me to believe the specified part is the bottleneck — PartyHatPanda
– PartyHatPanda, Commented Feb 15, 2017 at 16:43
Great. So now we need to figure out which part of that block is taking forever. Take your Debugs, add them on every line of that section, run it again and see what's happening. — Kaz
– Kaz, Commented Feb 15, 2017 at 16:44

Comintern · Accepted Answer · 2017-02-15 20:47:16Z

The first thing that jumps out is that you're testing with Like 6 times per cell. VBA's If doesn't short-circuit like other languages, so you'll test every single one even if the first condition is true. You can use Select Case for short circuiting by checking conditions against False. So, your condition...

For Each myCell In myRange If myCell.Value Like "*template*" Or myCell.Value Like "*TEMPLATE*" _ Or myCell.Value Like "*Template*" Or myCell.Offset(0, 2).Value Like "*template*" _ Or myCell.Offset(0, 2).Value Like "*TEMPLATE*" _ Or myCell.Offset(0, 2).Value Like "*Template*" Then

...can be re-written to short-circuit like this:

Select Case False Case myCell.Value Like "*template*" Case myCell.Value Like "*TEMPLATE*" Case myCell.Value Like "*Template*" Case myCell.Offset(0, 2).Value Like "*template*" Case myCell.Offset(0, 2).Value Like "*TEMPLATE*" Case myCell.Offset(0, 2).Value Like "*Template*" Case Default 'Condition not met. End Select

Better would be to use a regular expression, so you can perform case insensitive matching:

'Add a reference to VBScript Regular Expressions 5.5 'This goes outside the loop so it's only created once. With New RegExp .Pattern = ".*template.*" .IgnoreCase = True For Each myCell In myRange Dim found As Boolean found = .Test(myCell.Value) 'Only make the second test if you haven't found it already. If Not found Then found = .Test(myCell.Offset(0, 2).Value) If found Then If Not delete Is Nothing Then Set delete = Union(delete, myCell) Else Set delete = myCell End If End If Next myCell End With

The code above sidesteps the next huge performance hit in your loop, but you should be caching values for procedure calls that will always return the same result. In the quoted If statement at the start of the answer, you call myCell.Value 3 times and myCell.Offset(0, 2).Value 3 times. They'll always return the same thing, so put them in a local variable to avoid the repeated calls (note that in this case, Raystafarian's solution is doing the same thing, but on a much more "global" scale - it reduces all the .Value calls to just one).

Avoid superfluous procedure calls. Take this code for example:

For Each ws In final.Worksheets If ws.Name = "Entitlements" Or ws.Name = "Groups" Or ws.Name = "Accounts" Then Application.DisplayAlerts = False ws.delete Application.DisplayAlerts = True End If Next ws

You have the possibility of enabling and disabling .DisplayAlerts 3 times. Just do it once:

Application.DisplayAlerts = False For Each ws In final.Worksheets If ws.Name = "Entitlements" Or ws.Name = "Groups" Or ws.Name = "Accounts" Then ws.Delete End If Next ws Application.DisplayAlerts = True

Note that the code above is also a good regular expression candidate with a pattern something like "Entitlements|Groups|Accounts"

Don't discard return values that you need later. Consider this pattern that is repeated 3 times in the following:

final.Sheets.Add after:=final.Sheets(1) ActiveSheet.Name = "Entitlements" final.Sheets.Add after:=final.Sheets(1) ActiveSheet.Name = "Groups" final.Sheets.Add after:=final.Sheets(1) ActiveSheet.Name = "Accounts" sht.Cells.Clear Dim eSht As Worksheet, gSht As Worksheet, aSht As Worksheet Set eSht = final.Sheets("Entitlements") Set gSht = final.Sheets("Groups") Set aSht = final.Sheets("Accounts")

The first call to .Sheets.Add returns the sheet that was added. You can ditch the call to ActiveSheet to pick it up, and avoid the need to find it the second time in the .Sheets collection by simply doing this:

Set eSht = final.Sheets.Add(after:=final.Sheets(1)) eSht.Name = "Entitlements" Set gSht = final.Sheets.Add(after:=eSht) gSht.Name = "Groups" Set aSht = final.Sheets.Add(after:=gSht) aSht.Name = "Accounts"

Note that you can also re-use the objects immediately after you grab a reference instead of calling final.Sheets(1) 3 times.

You should remove dead code instead of commenting it out. I realize you're actively working on this, but that points to a need for source code management.

You don't need to initialize variables to their default values. This is do-nothing code:

aBkFound = False eBkFound = False gBkFound = False

On the other end of that spectrum, you don't need to set objects to Nothing right before they lose scope:

Set ws = Nothing Set wb = Nothing Set accountBook = Nothing Set entitlementsBk = Nothing Set groupBk = Nothing Set final = Nothing Set eSht = Nothing Set gSht = Nothing Set myRange = Nothing Set myCell = Nothing Set sortRange = Nothing Set delete = Nothing Set c = Nothing

This blog post by Eric Lippert explains this much better than I can, and probably a little more diplomatically.

Your code is doing too much unrelated work in one procedure. Going from top to bottom, you that these relatively discrete steps:

Make sure the right workbooks are open.
Add worksheets.
Move data.
Sort data.
Copy data.
Add headers.
Delete rows with "template" in them.

Each one of those should probably be extracted to at least one separate procedure. This makes your code easier to read, move expressive, more reusable, easier to debug, easier to benchmark, etc., etc.

jkpieterse · Accepted Answer · 2017-02-21 10:25:24Z

Lets give this a completely different twist.

Yes, code can be sped up by limiting reads/writes from/to Excel. But what also has a great impact is to have Excel do the work.

So use autofilter to filter the table for the rows you want to delete and then delete all visible rows. Probably three lines of code and very fast.

Something like:

Sub RemoveTemplateStrings() sht.UsedRange.AutoFilter Field:=1, Criteria1:="*template*" sht.UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete End Sub

Stack Exchange Network

Delete rows in spreadsheet where cells match some patterns

4 Answers 4

You must log in to answer this question.

Hot Network Questions

Delete rows in spreadsheet where cells match some patterns

4 Answers 4

You must log in to answer this question.

Related

Hot Network Questions