10
\$\begingroup\$

I'm a business student who just started to learn VBA. I am trying to write a macro for a project but only have minimal experience actually stepping into the code.

The macro I have written is to delete all row entries which do not meet my criteria if they contain certain words, including removing those with future month's dates in them, and I'd like for this to update based on the current month. I have found that normally the code runs very quickly, but when I add the last part, which removes those with future dates, the code becomes extremely slow.

Is there a way to speed it up or rewrite it so that it is faster?

Sub Remove_excess_entries()
    Dim lRow As Long
    Dim iCntr As Long
    lRow = 10000
    For iCntr = lRow To 1 Step -1
        If Cells(iCntr, 12).Value = "Mule" Or Cells(iCntr, 11).Value = "*R1*" Or Cells(iCntr, 11).Value = "*R2*" Or Cells(iCntr, 7).Value = "*Mule*" Or Cells(iCntr, 6).Value = "*Unassigned*" Or Cells(iCntr, 12).Value = "PS" Or Cells(iCntr, 7).Value = "Marketing" Or Cells(iCntr, 12).Value = "V1" Or DatePart("m", Cells(iCntr, 16).Value) > DatePart("m", Date) Then
            Rows(iCntr).Delete
        End If
    Next
End Sub
\$\endgroup\$
  • 3
    \$\begingroup\$ The answers address how the logic can be improved. It is worth mentioning that if you are deleting a large number of rows, you will get an additional bump in speed deleting all of them at once instead of one at a time. The UNION-DELETE technique is a typical way of doing that: stackoverflow.com/a/35605584/4288101 \$\endgroup\$ – Byron Wall Jun 13 '16 at 18:50
12
\$\begingroup\$

Here's that conditional, reformatted with line continuations for readability:

If Cells(iCntr, 12).Value = "Mule" _ 
    Or Cells(iCntr, 11).Value = "*R1*" _
    Or Cells(iCntr, 11).Value = "*R2*" _
    Or Cells(iCntr, 7).Value = "*Mule*" _
    Or Cells(iCntr, 6).Value = "*Unassigned*" _
    Or Cells(iCntr, 12).Value = "PS" _
    Or Cells(iCntr, 7).Value = "Marketing" _
    Or Cells(iCntr, 12).Value = "V1" _
    Or DatePart("m", Cells(iCntr, 16).Value) > DatePart("m", Date) _
Then
    Rows(iCntr).Delete
End If

There are a number of problems here:

  • Cells (and Rows) are implicit references to the active sheet; this means you're accessing the active worksheet without explicitly saying so - so if the macro takes a long while to run and the user decides to activate another sheet while it's running, your macro will fail to do what it was written for.
  • You're accessing the active sheet multiple times per row, and doing many checks that you may not need to be doing - if Cells(iCntr,11).Value is "*R1*", then every single next check is happening even though you already know you want to delete that row.

So how do you make it so that you only validate what needs to be validated, and that you don't access the worksheet more than you need to?

First make sure you specify Option Explicit at the top of the module. Option Explicit forces you to always declare all variables you're using, and that alone can prevent many bugs, since without it VBA will happily compile a typo.

Then make it one single read:

Dim target As Worksheet
Set target = Application.ActiveSheet

Dim rowValues()
Dim i As Long
For i = 10000 To 1 Step -1
    rowValues = target.Range(target.Cells(i, 1), target.Cells(i, 20)).Cells
    If IsUpForDeletion(rowValues) Then target.Rows(i).Delete
Next

Now, in one single worksheet operation, we've got an array that contains the values of columns 1-20 for row i; we call a function that returns a Boolean value when the row is "up for deletion", and so we remove that row when that function returns True.

The question is, what would this function do? Remember, we want it to only check what it needs to, and return as soon as it knows it should be returning True.

There's a little hack involving Select Case True that can help here:

Private Function IsUpForDeletion(ByRef rowValues()) As Boolean

    Dim result As Boolean
    result = True

    Select Case True
        Case rowValues(1, 5) = "*Unassigned*"
        Case rowValues(1, 6) = "*Mule*"
        Case rowValues(1, 6) = "Marketing"
        Case rowValues(1, 10) = "*R1*"
        Case rowValues(1, 10) = "*R2*"
        Case rowValues(1, 11) = "PS"
        Case rowValues(1, 11) = "V1"
        Case IsFutureMonth(rowValues(1, 15))
        Case Else
            result = False
    End Select

    IsUpForDeletion = result

End Function

Private Function IsFutureMonth(ByVal value As String) As Boolean

    If Not IsDate(value) Then
        IsFutureMonth = False
        Exit Function
    End If

    IsFutureMonth = DatePart("m", CDate(value)) > Month(Date)

End Function

VBA will evaluate each Case until it finds a condition that evaluates to True, and then immediately jump out and return. Because we're working with an in-memory 2D array here, and not accessing any cells, this is going to run much faster.

Notice the column indices are off by one - that's because VBA arrays are zero-based by default. If you want to refer to column 11 with an 11, then you could use Option Base 1 at the top of the module, and do this:

Private Function IsUpForDeletion(ByRef rowValues()) As Boolean

    Dim result As Boolean
    result = True

    Select Case True
        Case rowValues(1, 6) = "*Unassigned*"
        Case rowValues(1, 7) = "*Mule*"
        Case rowValues(1, 7) = "Marketing"
        Case rowValues(1, 11) = "*R1*"
        Case rowValues(1, 11) = "*R2*"
        Case rowValues(1, 12) = "PS"
        Case rowValues(1, 12) = "V1"
        Case IsFutureMonth(rowValues(1, 16))
        Case Else
            result = False
    End Select

    IsUpForDeletion = result

End Function

For even faster code, make one single read, and iterate an array instead of iterating a worksheet and making 10000 worksheet reads - this code should run orders of magnitude faster than your original code:

Option Base 1

Sub DoSomething()

    Dim target As Worksheet
    Set target = Application.ActiveSheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim rowValues()
    Dim i As Long
    rowValues = target.Range(target.Cells(1, 1), target.Cells(10000, 20)).Cells
    For i = 10000 To 1 Step -1
        If IsUpForDeletion(rowValues, i) Then target.Rows(i).Delete
    Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Private Function IsUpForDeletion(ByRef rowValues(), ByVal i As Long) As Boolean

    Dim result As Boolean
    result = True

    Select Case True
        Case rowValues(i, 6) = "*Unassigned*"
        Case rowValues(i, 7) = "*Mule*"
        Case rowValues(i, 7) = "Marketing"
        Case rowValues(i, 11) = "*R1*"
        Case rowValues(i, 11) = "*R2*"
        Case rowValues(i, 12) = "PS"
        Case rowValues(i, 12) = "V1"
        Case IsFutureMonth(rowValues(i, 16))
        Case Else
            result = False
    End Select

    IsUpForDeletion = result

End Function

Private Function IsFutureMonth(ByVal value As String) As Boolean

    If Not IsDate(value) Then
        IsFutureMonth = False
        Exit Function
    End If

    IsFutureMonth = DatePart("m", CDate(value)) > Month(Date)

End Function
\$\endgroup\$
  • \$\begingroup\$ I just realized that the part with Select Case for row values containing Unassigned, Mule, and Marketing isn't working, and I'm thinking maybe it's just my data set that's incorrect and not the code. Any ideas why that wouldn't work? If not I was going to write another macro to do that part, but when I do I get an error saying "Block If without End If" even though I have an end if \$\endgroup\$ – Student L Jun 14 '16 at 13:47
  • \$\begingroup\$ Finally one out on my own so never mind! \$\endgroup\$ – Student L Jun 14 '16 at 13:56
  • 1
    \$\begingroup\$ I like how clearly you write code and can learn a lot from your style. The single read and in memory array is efficient, but the code is still deleting a row. Why not load into memory, clear the sheet, transform the array, then dump the array to the sheet? \$\endgroup\$ – emican Jun 15 '16 at 1:02
  • \$\begingroup\$ @user14218 thanks! The thing is that the array will only ever contain the cell values; doing what you say would work, if there is no formatting involved anywhere - otherwise a better approach would be to union the rows to delete and make one single delete operation =) \$\endgroup\$ – Mathieu Guindon Jun 15 '16 at 1:10
4
\$\begingroup\$

Add Application.ScreenUpdating = False to the start of your Sub and Application.ScreenUpdating = True to the end.

This will have far more of an impact on performance than anything else you might do (unless your spreadsheet is really big).

Like so:

Sub Remove_excess_entries()
    Application.ScreenUpdating = False

    Dim lRow As Long
    Dim iCntr As Long
    lRow = 10000
    For iCntr = lRow To 1 Step -1
        If Cells(iCntr, 12).Value = "Mule" Or Cells(iCntr, 11).Value = "*R1*" Or Cells(iCntr, 11).Value = "*R2*" Or Cells(iCntr, 7).Value = "*Mule*" Or Cells(iCntr, 6).Value = "*Unassigned*" Or Cells(iCntr, 12).Value = "PS" Or Cells(iCntr, 7).Value = "Marketing" Or Cells(iCntr, 12).Value = "V1" Or DatePart("m", Cells(iCntr, 16).Value) > DatePart("m", Date) Then
            Rows(iCntr).Delete
        End If
    Next

    Application.ScreenUpdating = True
End Sub
\$\endgroup\$
  • \$\begingroup\$ Comments are not for extended discussion; this conversation has been moved to chat. \$\endgroup\$ – Mathieu Guindon Jun 13 '16 at 15:50
  • \$\begingroup\$ I'll head back thanks for the heads up. I believe it should run fine after including the trim function \$\endgroup\$ – Student L Jun 13 '16 at 15:55
3
\$\begingroup\$

Deleting rows one at a time is by far the slowest thing you are doing. It is many times faster to do a single delete operation on the union of all the ranges you want to delete.

Public Sub DeleteFast(sheet As Worksheet)

  Dim startTime As Long
  startTime = Timer

  Dim i As Long
  Dim toDelete As Range

  'Note: no reason to go backward
  For i = 1 To 40000
    If toDelete Is Nothing Then
      Set toDelete = sheet.Rows(i)
    Else
      Set toDelete = Union(toDelete, sheet.Rows(i))
    End If
  Next

  toDelete.Delete

  Debug.Print "DeleteFast took " & (Timer - startTime) * 1000 & "ms"

End Sub

The VBA culture is full of myths, outdated conventions, and cargo-cult programming. I urge you to test the advice you get yourself. The code above deletes 40,000 rows in a single operation, and runs about 40x faster for me than the code below. Test this yourself against two sheets that have 40,000 rows of data. For comparison, here is by-row version:

Public Sub DeleteSlow(sheet As Worksheet)

  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  Dim startTime As Long
  startTime = Timer

  Dim i As Long

  For i = 40000 To 1 Step -1
    sheet.Rows(i).Delete
  Next

  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic

  Debug.Print "DeleteSlow took " & (Timer - startTime) * 1000 & "ms"

End Sub

If you do it this way, you don't need to make calculations manual or turn off screen updating, which are ugly and difficult to always switch back (and you must, always). Consider what happens if your code throws an error: you should have a Catch block that cleans up Application-wide variables to prevent them getting stuck. You also don't need to iterate backward.

Some other notes: as others have mentioned, don't use functions that depend on the currently active worksheet such as Rows. For macros and buttons, it's OK to capture the currently active worksheet (or selection, or whatever you need) immediately, but then you should pass them around as Range or Worksheet variables.

Use this in conjunction with Mat's Mug's answer. I didn't believe him that putting the cells in an array would make any difference, but I tested it and it actually did give about a 3x improvement over reading each cell individually. For those wanting to test the performance difference themselves, here's some test code (I recommend having only one cell with an X in it):

Public Sub ManyReads(sheet As Worksheet)

    Dim startTime As Long
    startTime = Timer

    Dim row As Long
    Dim column As Long

    For row = 1 To 40000
      For column = 1 To 20
        If sheet.Cells(row, column) = "X" Then Debug.Print "Schmarbs"
      Next
    Next

    Debug.Print "ManyReads took " & (Timer - startTime) * 1000 & "ms"

End Sub

Public Sub OneRead(sheet As Worksheet)

    Dim startTime As Long
    startTime = Timer

    Dim cellsInAnArray()

    cellsInAnArray = sheet.Range("A1:T40000")

    Dim row As Long
    Dim column As Long

    For row = 1 To 40000
      For column = 1 To 20
        If cellsInAnArray(row, column) = "X" Then Debug.Print "Schmarbs"
      Next
    Next

    Debug.Print "OneRead took " & (Timer - startTime) * 1000 & "ms"

End Sub
\$\endgroup\$
  • \$\begingroup\$ Excellent answer - note that Timer has an approx. 15ms resolution since it's counting ticks since system-clock midnight (and thus won't return correct measures if execution overlaps midnight). The single slowest thing to do in Excel VBA is accessing cells /interacting with a worksheet - by making a single deletion, you hit the nail on the head! FWIW I didn't mention error handling for simplicity, but you make a very good point about handling errors while ScreenUpdating is disabled. Note that my code won't try to convert a non-date value into a date though, IsUpForDeletion can't blow up =) \$\endgroup\$ – Mathieu Guindon Jun 14 '16 at 0:07
2
\$\begingroup\$

My standard answer to "how do I do this faster?" in VBA is to use the ADODB library to execute a SQL query against the Excel sheet. It's orders of magnitude faster than accessing the sheet directly, with the added benefit that you don't even have to open the worksheet up in an instance of Excel. It's a technique well worth learning.

\$\endgroup\$
1
\$\begingroup\$

Here follows a solution to answer the request "Is there a way to speed it up or rewrite it so that it is faster?"

It takes the move from the consideration that the most time consuming activities are:

  • deleting rows one by one

  • rearranging rows below the deleted one

So it uses sorting technique to:

  1. gather all rows to be deleted at the end of data, while keeping relative positions for surviving rows
  2. delete them in one shot

The final outcome is that it's way faster then all other methods explicitly coded here up to date (it'd be fine to compare it to "SQL query" technique as well)

Furthermore I propose a code style to improve its readability and, therefore, debugging and maintenance

So let's get started

Let's begin with code style, with which we'll write the above explained algorithm down

I agree with those who tend to sub-divide each specific works to dedicated subs and/or functions. This is also useful to try and reuse it as much as possible, but without relying on this feature too much: the 1st goal is the clearness and maintenance of the current code.

But even more important is the to achieve a "real" readability of the code: the user (the coder himself, for starters) must be able to read the code as if it were (almost) a book page. This means the code must not be cluttered with many (let alone nested) loops and/or If-Then-Else block that forces the reader to first interpret the algorithm flux before being able to grasp the logic behind it.

For instance a not so readable, yet functioning (and fast) code could be the following:

Option Explicit

Sub Remove_excess_entries()
    Dim dataArr As Variant, dataCheckArr() As Long, indexesArr() As Long
    Dim i As Long

    With Worksheets("myDataSheet") '<--| use always explicit reference to the relevant worksheet
        With .Range("A1:P1") '<--| set the first row of the relevant data
            dataArr = .Resize(Parent.Cells(.Parent.Rows.Count, 1).End(xlUp).Row - .Rows(1).Row + 1).value '<--| get all relevant data into an array
        End With

        'fill the "check" array
        ReDim dataCheckArr(LBound(dataArr, 1) To UBound(dataArr, 1)) As Long '<--| redim "dataCheckArr" to fit "dataArr"
        ReDim indexesArr(LBound(dataArr, 1) To UBound(dataArr, 1)) As Long '<--| redim "indexesArr" to fit "dataArr"
        For i = LBound(dataArr, 1) To UBound(dataArr, 1)
            If IsUpForDeletion(dataArr, i) Then dataCheckArr(i) = 1 '<--| mark rows to be deleted with "1"
            indexesArr(i) = i '<--| store initial rows relative position
        Next i

        'delete rows
        If WorksheetFunction.Sum(dataCheckArr) > 0 Then '<--| if there is any row marked for deletion
            Application.ScreenUpdating = False
            .Range("Q1").Resize(UBound(dataCheckArr)) = Application.Transpose(dataCheckArr) '<--| write down the "to be deleted" helper column
            .Range("R1").Resize(UBound(dataCheckArr)) = Application.Transpose(indexesArr) '<--| write down the "original order" helper column
            .Range("A1:R1").Resize(UBound(indexesArr)).Sort key1:=.Range("Q1"), order1:=xlDescending '<--| sort data to group columns to be deleted at its end
            .Range("Q1").Resize(WorksheetFunction.Sum(dataCheckArr)).EntireRow.Delete '<--| delete rows, at least!
            .Range("A1:R1").Resize(UBound(indexesArr) - WorksheetFunction.Sum(dataCheckArr)).Sort key1:=.Range("R1"), order1:=xlAscending '<--| sort data back to its original rows relative position
            .Range("Q1:R1").Resize(UBound(indexesArr) - WorksheetFunction.Sum(dataCheckArr)).Clear '<--| clear helper columns
            Application.ScreenUpdating = True
        End If
    End With
End Sub

where I borrowed (and implicitly assumed) the IsUpForDeletion() function from Mat's Mug

the above is quite a short code but still it's uselessly cluttered with info that prevent the "reader" to deal with "bare" code logic.

in other words, despite the comments, the code is not speaking to the reader who'll have hard time to get to what the coder wanted to achieve and, mainly, how.

And this stars from the very beginning, with variable declarations among which those (actually only Dim i as Long, but it suffices as an example) not strictly connected with code "core business"

Consider now the following code

Option Explicit

Sub Remove_excess_entries()
    Dim dataArr As Variant, dataCheckArr As Variant, indexesArr As Variant
    Dim dataFirstRowRng As Range

    Set dataFirstRowRng = Worksheets("myDataSheet").Range("A1:P1") '<--| set the first row of the relevant data

    GetDataIntoArray dataFirstRowRng, 1, dataArr '<--| get all relevant data into an array
    ArrayDataCheck dataArr, dataCheckArr, indexesArr '<--| fill the "check" array
    DeleteRows dataFirstRowRng, dataCheckArr, indexesArr '<--| delete rows
End Sub

Such a code is actually speaking to the reader so that comments could be removed without affecting code readability at all.

It's quite clear that the logic of the algorithm is:

  1. set the relevant data range
  2. get those data into an array
  3. check data
  4. delete rows (at least!)

No loops, no If-Then-Else block, only plain speaking to the reader. All the dirty work is being done behind the scenes, i.e. in specific subs and functions.

Of course, this refactoring could be extended to those specific subs and functions also, although I believe this can be done only to a certain extent, not to loose readability for much too verbosity.

Stopping as for now at the main sub refactoring step, the whole code would be the following:

Option Explicit

Sub Remove_excess_entries()
    Dim dataArr As Variant, dataCheckArr As Variant, indexesArr As Variant
    Dim dataFirstRowRng As Range

    Set dataFirstRowRng = Worksheets("myDataSheet").Range("A1:P1") '<--| set the first row of the relevant data

    GetDataIntoArray dataFirstRowRng, 1, dataArr '<--| get all relevant data into an array
    ArrayDataCheck dataArr, dataCheckArr, indexesArr '<--| fill the "check" array
    DeleteRows dataFirstRowRng, dataCheckArr, indexesArr '<--| delete rows
End Sub


Sub DeleteRows(dataFirstRowRng As Range, dataCheckArr As Variant, indexesArr As Variant)
    Dim nRowsToDelete As Long, nRows As Long

    nRows = UBound(dataCheckArr) - LBound(dataCheckArr) + 1 '<--| count data rows number
    nRowsToDelete = WorksheetFunction.Sum(dataCheckArr) '<--| count number of rows "marked" for deletion...
    If nRowsToDelete > 0 Then '<--| if there is any row marked for deletion
        Application.ScreenUpdating = False '<--| turn screenupdating off right before it's useful to do it
        With dataFirstRowRng '<--| hold reference to the data first row
            .Resize(nRows, 1).Offset(, .Columns.Count) = Application.Transpose(dataCheckArr) '<--| write down the "to be deleted" helper column
            .Resize(nRows, 1).Offset(, .Columns.Count + 1) = Application.Transpose(indexesArr) '<--| write down the "original relative rows order" helper column
            .Resize(nRows, .Columns.Count + 2).Sort key1:=.Offset(, .Columns.Count).Resize(, 1), order1:=xlAscending, key2:=.Offset(, .Columns.Count + 1).Resize(, 1), order2:=xlAscending '<--| sort data to group columns to be deleted at its end

            .Offset(nRows - nRowsToDelete).Resize(nRowsToDelete).EntireRow.Delete  '<--| delete rows, at least!

            .Resize(nRows - nRowsToDelete, 2).Offset(, .Columns.Count).Clear '<--| clear helper columns
        End With
        Application.ScreenUpdating = True
    End If
End Sub


Sub GetDataIntoArray(firstRowRrng As Range, colIndexMaxRows As Long, dataArr As Variant)
    ' fills the passed variant array (dataArr) with the content of a range determined as follows:
    ' - first row as the passed one (firstRowRrng)
    ' - last row as the last with non empty cell in the passed column (colIndexMaxRows)
    With firstRowRrng
        dataArr = .Resize(Parent.Cells(.Parent.Rows.Count, colIndexMaxRows).End(xlUp).Row - .Rows(1).Row + 1).value
    End With
End Sub


Sub ArrayDataCheck(dataArr As Variant, dataCheckArr As Variant, indexesArr As Variant)
    ' fills the last two passed variant arrays (dataCheckArr and indexesArr) as follows:
    ' - dataCheckArr
    '     is filled with "1" at indexes corresponding to rows to be kept
    '     therefore its "empty" values corresponds to rows to be deleted
    ' - indexesArr
    '     is filled with ascending number from 1 up
    '     it'll be used for holding (before sorting and deletion) and restoring (after deletion) original data rows relative position

    Dim i As Long
    ReDim dataCheckArr(LBound(dataArr, 1) To UBound(dataArr, 1)) As Variant '<--| redim "dataCheckArr" to fit "dataArr"
    ReDim indexesArr(LBound(dataArr, 1) To UBound(dataArr)) As Variant '<--| redim "indexesArr" to fit "dataArr"

    For i = LBound(dataArr, 1) To UBound(dataArr, 1)
        dataCheckArr(i) = IsUpForDeletion(dataArr, i) '<--| mark rows to be deleted with "1"
        indexesArr(i) = i '<--| store initial rows relative position
    Next i
End Sub

Private Function IsUpForDeletion(ByRef rowValues, ByVal i As Long) As Long
    IsUpForDeletion = 1
    Select Case True
        Case rowValues(i, 6) = "*Unassigned*"
        Case rowValues(i, 7) = "*Mule*"
        Case rowValues(i, 7) = "Marketing"
        Case rowValues(i, 11) = "*R1*"
        Case rowValues(i, 11) = "*R2*"
        Case rowValues(i, 12) = "PS"
        Case rowValues(i, 12) = "V1"
        Case IsFutureMonth(rowValues(i, 16))
        Case Else
            IsUpForDeletion = 0
    End Select
End Function

Private Function IsFutureMonth(ByVal value As String) As Boolean
    If Not IsDate(value) Then Exit Function
    IsFutureMonth = DatePart("m", CDate(value)) > Month(Date)
End Function

thus leaving sub and function refactoring steps to whoever interested

some side notes:

  • I slightly modified IsUpForDeletion() function to

    return a Long instead of a Boolean value to avoid useless checking (like If IsUpForDeletion(dataArr, i) then dataCheckArr(i) = 1) and use it to directly populate dataCheckArr (dataCheckArr(i) = IsUpForDeletion(dataArr, i))

  • I slightly simplified IsFutureMonth() function, changing

   If Not IsDate(value) Then
       IsFutureMonth = False
       Exit Function
 End If

to

If Not IsDate(value) Then Exit Function

since a Boolean function is always initialized to False

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