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?

• Raystafarian: So if a row contains the string "template" regardless of case, remove it?
• PartyHatPanda: @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!
• Mathieu Guindon: 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?
• Kaz: 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: @PartyHatPanda Yes, SO and CR, have different, in fact opposite requirements for useful questions. Over here, more information and context is always better.

Answer 1

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

Answer 2

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.

• PartyHatPanda: 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
• Kaz: 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.

Answer 3

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:

1. Make sure the right workbooks are open.
2. Add worksheets.
3. Move data.
4. Sort data.
5. Copy data.
6. Add headers.
7. 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.

Answer 4

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