# VBA macro - searches through a filtered table, stops when entry passes criteria

I have written several subs which are then called from a main sub. Individual subs run very quickly, most are instantaneous (the DoFind sub takes a few seconds to run due to the large amounts of data in the table) however when I run the main sub it takes up to a minute to execute. Any ideas/tips on why this is the case?

Note, I haven't had much experience with VBA (all has been learnt in the past week). There are other macros used, but they are not shown since even the test sub takes approximately 1 minute

Sub DoFind()

Dim i As Long

i = 1

Do While Sheets("Temp").Cells(i, "A").Value <> Empty

Dim BearingArray(6) As String

BearingArray(0) = Sheets("Temp").Cells(i, "A").Value
BearingArray(1) = Sheets("Temp").Cells(i, "B").Value
BearingArray(2) = Sheets("Temp").Cells(i, "C").Value
BearingArray(3) = Sheets("Temp").Cells(i, "D").Value
BearingArray(4) = Sheets("Temp").Cells(i, "E").Value
BearingArray(5) = Sheets("Temp").Cells(i, "F").Value
BearingArray(6) = Sheets("Temp").Cells(i, "G").Value

With Sheets("Calculations")
.Cells(17, "K").Value = BearingArray(0)
.Cells(19, "O").Value = BearingArray(1)
.Cells(20, "O").Value = BearingArray(2)
.Cells(23, "O").Value = BearingArray(3)
.Cells(22, "O").Value = BearingArray(4)
.Cells(26, "O").Value = BearingArray(5)
.Cells(17, "L").Value = BearingArray(6)
End With

i = i + 1

If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then
Exit Do
Else
End If
Loop
If Sheets("Temp").Cells(i, "A").Value = Empty Then
MsgBox "No available bearing."

End If

End Sub


Sub Create_Sheet_Temp()

ActiveSheet.Name = "Temp"

' This creates a new worksheet called "Temp"

End Sub


Sub Copy_Paste()

Dim NewTable As ListObject
Sheets("Calculations").Activate

Set NewTable = Sheets("Calculations").ListObjects("Full_Bearings_List")

NewTable.Range.SpecialCells(xlCellTypeVisible).Select
NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
Sheets("Temp").Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False

'This sub copies all visible cells from a filtered table and pastes them to the new sheet called "Temp"

End Sub


Sub test()
Create_Sheet_Temp
Copy_Paste
DoFind

End Sub

• Hi and Welcome to Code Review. Could you expand a bit on the context your code runs in and what it does? What problem is it trying to solve? What are your Inputs & Desired Outputs? Do you have control over the format of your input data or are there restrictions you have to work with? – Kaz Jul 18 '16 at 11:59
• It will also be impossible to tell why your main sub is slow if we can't actually see it. If you want it reviewed and improved, then we need to see the code for it. – Kaz Jul 18 '16 at 12:31
• Please, feel free to paste all the code. The more we can see, the more we can make specific recommendations for your situation and join things up in useful ways. – Kaz Jul 18 '16 at 12:39
• @Zak The 'test' sub is the main sub, and this is the one I am having an issue with. The 'DoFind' sub on its own takes about 6 seconds, and the 'Create_Sheet_Temp' and 'Copy_Paste' subs each take less than 1 second, but when the three are called consecutively in the 'test' sub it takes about 45 seconds to run. I don't understand what could account for such a large time difference, and would appreciate any advice as so far none of the changes I have made (such as using destination instead of copy and paste) have made a noticeable difference to the 'test' sub run-time. – Robin Jul 18 '16 at 13:30
• I edited my answer to add some simple performance improvements. – Kaz Jul 18 '16 at 13:37

First, I'd just like to say: This is decent code for someone who's brand new to VBA. Great work.

That aside, let's begin:

## Option Explicit

If that's not at the top of all your code modules, put it in. Go to Tools --> Options --> Require Variable Declaration to have it auto-inserted into every new module you create.

## Easy Performance Improvements

Sub DoThing()

With Application
.ScreenUpdating = False
.EnableEvents = False
.StatusBar = False
.Calculation = xlCalculationManual
End With

...

...

Code

...

...

With Application
.ScreenUpdating = True
.EnableEvents = True
.StatusBar = True
.Calculation = xlCalculationAutomatic
End With

End Sub


Each of those settings will provide large performance improvements. Especially ScreenUpdating. Always check that you're not reliant on the thing you're disabling though. For instance, DoFind() is relying on a formula to change, so you shouldn't disable Calculation.

## Consistent Indenting

Pick an indenting rule and stick to it. Personally, I use a single Tab for each logical level (If, While, With, etc.) and it's a widespread convention with VBA. This way, I can easily identify which statements are operating at what level.

Something like this is particularly confusing:

               If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then
Exit Do
Else
End If


It's much easier to "see" what's going on when it's expressed like this:

If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then
Exit Do
End If


I would re-indent your DoFind sub like so:

Sub DoFind()

Dim i As Long
i = 1

Do While Sheets("Temp").Cells(i, "A").Value <> Empty

Dim BearingArray(6) As String
BearingArray(0) = Sheets("Temp").Cells(i, "A").Value
BearingArray(1) = Sheets("Temp").Cells(i, "B").Value
BearingArray(2) = Sheets("Temp").Cells(i, "C").Value
BearingArray(3) = Sheets("Temp").Cells(i, "D").Value
BearingArray(4) = Sheets("Temp").Cells(i, "E").Value
BearingArray(5) = Sheets("Temp").Cells(i, "F").Value
BearingArray(6) = Sheets("Temp").Cells(i, "G").Value

With Sheets("Calculations")
.Cells(17, "K").Value = BearingArray(0)
.Cells(19, "O").Value = BearingArray(1)
.Cells(20, "O").Value = BearingArray(2)
.Cells(23, "O").Value = BearingArray(3)
.Cells(22, "O").Value = BearingArray(4)
.Cells(26, "O").Value = BearingArray(5)
.Cells(17, "L").Value = BearingArray(6)
End With

i = i + 1

If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then
Exit Do
End If

Loop

If Sheets("Temp").Cells(i, "A").Value = Empty Then
MsgBox "No available bearing."
End If

End Sub


Much easier to follow.

## Naming

I recommend the Excellent, Classic article on naming by Joel spolsky.

Naming is, famously, one of the 2 hardest things in software development. It's also one of the most important. Code should be written for other people (including future you) to understand as easily and completely as possible.

Names should be descriptive, then unambiguous, and only then concise. Variables should sound like what they are. I should be able to tell from the name of a Sub/Function exactly what it does.

DoFind. This tells me nothing.

FindBearing would be better. I'd offer you an even better name, but there's not enough context to be sure what the rest of your code/workbook is doing and why.

Create_Sheet_Temp. Don't use _ in procedure names. _ in VBA is used for event triggers e.g. Workbook_Open or Button_OnClick. Avoid it in your own names to avoid confusion.

Copy_Paste. Useless. Copy what? Paste what? Paste where?. PasteBearingDataToTempSheet. Sure, it's a bit verbose, but it's also useful. You should always aim for useful names. If you can make them short as well, great, but it's not the priority.

## Use the Object Model

The great power of VBA for manipulating MS Office is the extensive Object Model it's integrated with.

There are objects for everything. Workbooks, Worksheets, ListObjects, Ranges etc.

Take this for instance:

        BearingArray(0) = Sheets("Temp").Cells(i, "A").Value
BearingArray(1) = Sheets("Temp").Cells(i, "B").Value
BearingArray(2) = Sheets("Temp").Cells(i, "C").Value
BearingArray(3) = Sheets("Temp").Cells(i, "D").Value
BearingArray(4) = Sheets("Temp").Cells(i, "E").Value
BearingArray(5) = Sheets("Temp").Cells(i, "F").Value
BearingArray(6) = Sheets("Temp").Cells(i, "G").Value


What happens if/when your temp sheet has a different name than "Temp"? How about if someone renames the "Calculations" sheet? Not only will your code break, but you'll have to change those strings everywhere in your code. Maybe you'll get them all. Maybe you won't. Chances are, it will introduce new errors.

Instead, make some Worksheet objects and use those:

Sub NewTest()

Dim tempSheet As Worksheet

Dim calculationSheet As Worksheet
Set calculationSheet = ThisWorkbook.Sheets("Calculations")

PasteBearingDataToTempSheet tempSheet, calculationSheet

FindBearing tempSheet, calculationSheet

End Sub

Sub PasteBearingDataToTempSheet(ByRef tempSheet As Worksheet, ByRef calculationSheet As Worksheet)

calculationSheet.Activate

Dim NewTable As ListObject
Set NewTable = calculationSheet.ListObjects("Full_Bearings_List")

NewTable.Range.SpecialCells(xlCellTypeVisible).Select
NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy

tempSheet.Range("A1").PasteSpecial xlPasteAll

Application.CutCopyMode = False

'This sub copies all visible cells from a filtered table and pastes them to the new sheet called "Temp"

End Sub

Sub FindBearing(ByRef dataSheet As Worksheet, ByRef calculationSheet As Worksheet)

Dim i As Long
i = 1

Do While dataSheet.Cells(i, "A").Value <> Empty

Dim BearingArray(6) As String
With dataSheet
BearingArray(0) = .Cells(i, "A").Value
BearingArray(1) = .Cells(i, "B").Value
BearingArray(2) = .Cells(i, "C").Value
BearingArray(3) = .Cells(i, "D").Value
BearingArray(4) = .Cells(i, "E").Value
BearingArray(5) = .Cells(i, "F").Value
BearingArray(6) = .Cells(i, "G").Value
End With

With calculationSheet
.Cells(17, "K").Value = BearingArray(0)
.Cells(19, "O").Value = BearingArray(1)
.Cells(20, "O").Value = BearingArray(2)
.Cells(23, "O").Value = BearingArray(3)
.Cells(22, "O").Value = BearingArray(4)
.Cells(26, "O").Value = BearingArray(5)
.Cells(17, "L").Value = BearingArray(6)
End With

i = i + 1

If calculationSheet.Cells(17, "M").Value = "PASS" Then
Exit Do
End If

Loop

If dataSheet.Cells(i, "A").Value = Empty Then
MsgBox "No available bearing."
End If

End Sub


Now, if either of those names change, you only have to change the declaration in one place, and the rest of your code will continue running perfectly. Notice how we don't even have to name the tempSheet. We just create it directly into a worksheet object.

        If calculationSheet.Cells(17, "M").Value = "PASS" Then
Exit Do
End If


What is the significance of the particular cell? How do we know what it's supposed to be? And how do we check that it is what it's supposed to be?

Depending on your workbook, my first suggestion would be to make that cell a Named Range.

If we named that cell "ValidateBearing" then we could do the following:

    Dim validationCell As Range
Set validationCell = ThisWorkbook.Names("ValidateBearing").RefersToRange

Const VALIDATION_PASS_TEXT As String = "PASS"

Do While dataSheet.Cells(i, "A").Value <> Empty

...

...

If validationCell.Text = VALIDATION_PASS_TEXT Then
Exit Do
End If


And now, not only have we made it clear what that cell is and what it's doing, but that cell can now move around as much as it likes. As long as nobody actually deletes the row/column/sheet it's in, that code will always point to the right place.

## Other tips & Tricks

Do While dataSheet.Cells(i, "A").Value <> Empty


should be

Do While Not IsEmpty(dataSheet.Cells(i, 1))


    If dataSheet.Cells(i, "A").Value = Empty Then
MsgBox "No available bearing."
End If


This is hacky. Add a proper Boolean variable to check for conditions:

    Dim foundBearing As Boolean
foundBearing = False

Do While Not IsEmpty(dataSheet.Cells(i, 1))

...

...

If validationCell.Text = VALIDATION_PASS_TEXT Then
foundBearing = True
Exit Do
End If

Loop

MsgBox "No available bearing."
End If


You can drop .Select everywhere and always.

A.B.Select
Selection.DoThing


Is always the same as just doing

A.B.DoThing


Here:

    NewTable.Range.SpecialCells(xlCellTypeVisible).Select
NewTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy


You can drop the first line entirely and it will still run perfectly fine.

Get used to using Sheet.Cells(row, column) instead of Sheet.Range("[Address]"). Not only is it faster, but it's semantically closer to what cells actually are, and you can't do things like this anywhere near as easily with addresses:

Dim startRow As Long
startRow = 1

Dim finalRow  As Long
finalRow = [Get final Row]

Dim startColumn As Long
startColumn = 1

Dim finalColumn As Long
finalColumn = [Get final Column]

Dim iRow As Long
Dim iColumn As Long

For iRow = startRow To finalRow
For iColumn = startColumn To finalColumn

With [Sheet].Cells(iRow, iColumn)

[Do Stuff]

End With

Next iColumn
Next iRow

• Thank you very much for taking the time to help me out. All your points make sense and I understand why you should do it the way you say. – Robin Jul 18 '16 at 13:58

I'd say the real speed issue is the calculation time and your actual code couldn't work disabling it

in fact there's that

    If Sheets("Calculations").Cells(17, "M").Value = "PASS" Then
Exit Do
End If


inside that

Do While Sheets("Temp").Cells(i, "A").Value <> Empty


and Sheets("Calculations").Cells(17, "M") isn't set by any statement of your code so I assume that cell holds a formula that must be evaluated at every loop iteration to know if it results in a "PASS" and consequently exit it

so the real fix would be taking all necessary calculation currently happening in excel UI out of excel cells and porting it inside VBA code

whether you could succeed in that task or not, there's some code enhancement that can still (after Zak's fine pieces of advice) be made

Avoid unnecessary dimming

you put

Dim BearingArray(6) As String


right inside

Do While Sheets("Temp").Cells(i, "A").Value <> Empty


while it's not necessary (since all BearingArray() elements are set at every itaration) and increases execution time

so to speed things up you want to code like follows

Dim i As Long
Dim BearingArray(6) As String '<--| dim it once!

i = 1
Do While Sheets("Temp").Cells(i, "A").Value <> Empty


Avoid unnecessary reading and writing variables

but you don't even need to pass through any array (BearingArray()) to reach your final goal, which is writing into some Sheets("Calculations") cells

so that you can avoid both dimming and assigning BearingArray() and directly write into cells like follows:

Dim i As Long

i = 1
Do While Sheets("Temp").Cells(i, "A").Value <> Empty

With Sheets("Calculations")
.Cells(17, "K").Value = Sheets("Temp").Cells(i, "A").Value
.Cells(19, "O").Value = Sheets("Temp").Cells(i, "B").Value
.Cells(20, "O").Value = Sheets("Temp").Cells(i, "C").Value
.Cells(23, "O").Value = Sheets("Temp").Cells(i, "D").Value
.Cells(22, "O").Value = Sheets("Temp").Cells(i, "E").Value
.Cells(26, "O").Value = Sheets("Temp").Cells(i, "F").Value
.Cells(17, "L").Value = Sheets("Temp").Cells(i, "G").Value
End With


and I'd here remind once again that writing into cells and calculating is quite a time consuming activity, so better find a way to take all calculation inside VBA code and leave excel UI just for input and output purposes

Use With keyword

to avoid unnecessary memory accesses, use With keyword for multiple reference to the same object

since you have two sheets to reference inside your loop, you can handle one of them with With keyword and the other one by setting a Range and offsetting from it, like follows:

Dim cell As Range, loopRng As Range

Set loopRng = Sheets("Temp").Columns("A").SpecialCells(xlCellTypeFormulas, xlNumbers) '<--| gather all non blank cells of "Temp" sheet column "A" in one Range variable
With Sheets("Calculations") '<--| assume "Calculations" sheet reference once for the whole loop
For Each cell In loopRng '<--| loop through non blank cells only
.Cells(17, "K").Value = cell.Offset(, 0).Value '<--| use offset() from cell to get the wanted value
.Cells(19, "O").Value = cell.Offset(, 1).Value
.Cells(20, "O").Value = cell.Offset(, 2).Value
.Cells(23, "O").Value = cell.Offset(, 3).Value
.Cells(22, "O").Value = cell.Offset(, 4).Value
.Cells(26, "O").Value = cell.Offset(, 5).Value
.Cells(17, "L").Value = cell.Offset(, 6).Value
If .Cells(17, "M").Value = "PASS" Then Exit For
Next cell
End With


this way you also avoid the dimming, initializing and updating of i variable

Avoid unnecessary IF statements

If Sheets("Temp").Cells(i, "A").Value = Empty Then


can be avoided since you know if you pass the "PASS" check or you don't

so you can code like follows

With Sheets("Calculations") '<--| assume "Calculations" sheet reference once for the whole loop
For Each cell In loopRng '<--| loop through non blank cells only
...
...
If .Cells(17, "M").Value = "PASS" Then Exit Sub '<-- directly exit the sub upon passing the check
End With

MsgBox "No available bearing." '<-- once you get here there's no doubt: you didn't PASS


Summary

recapitulating all what above your DoFind() sub would get to

Option Explicit

Sub DoFind()
Dim cell As Range, loopRng As Range '<--define range objects

Set loopRng = Sheets("Temp").Columns("A").SpecialCells(xlCellTypeFormulas, xlNumbers)
With Sheets("Calculations")
For Each cell In loopRng
.Cells(17, "K").Value = cell.Offset(, 0).Value
.Cells(19, "O").Value = cell.Offset(, 1).Value
.Cells(20, "O").Value = cell.Offset(, 2).Value
.Cells(23, "O").Value = cell.Offset(, 3).Value
.Cells(22, "O").Value = cell.Offset(, 4).Value
.Cells(26, "O").Value = cell.Offset(, 5).Value
.Cells(17, "L").Value = cell.Offset(, 6).Value
If .Cells(17, "M").Value = "PASS" Then Exit Sub
Next cell
End With
MsgBox "No available bearing."
End Sub