12
\$\begingroup\$

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?

\$\endgroup\$
  • \$\begingroup\$ So if a row contains the string "template" regardless of case, remove it? \$\endgroup\$ – Raystafarian Feb 15 '17 at 16:11
  • \$\begingroup\$ @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! \$\endgroup\$ – PartyHatPanda Feb 15 '17 at 16:13
  • 3
    \$\begingroup\$ 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? \$\endgroup\$ – Mathieu Guindon Feb 15 '17 at 16:20
  • 2
    \$\begingroup\$ 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? \$\endgroup\$ – Kaz Feb 15 '17 at 16:23
  • 4
    \$\begingroup\$ @PartyHatPanda Yes, SO and CR, have different, in fact opposite requirements for useful questions. Over here, more information and context is always better. \$\endgroup\$ – Kaz Feb 15 '17 at 16:24
11
\$\begingroup\$

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
\$\endgroup\$
6
\$\begingroup\$

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.

\$\endgroup\$
  • 1
    \$\begingroup\$ 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 \$\endgroup\$ – PartyHatPanda Feb 15 '17 at 16:43
  • \$\begingroup\$ 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. \$\endgroup\$ – Kaz Feb 15 '17 at 16:44
5
\$\begingroup\$

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.

\$\endgroup\$
2
\$\begingroup\$

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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.