Ways to inrease the speed of VBA code

Question

I have been trying to use VBA for a couple of months now, but I'm not sure I code very efficiently when it comes to speed.

The below code is a calculation of zscores used in a ranking model for stocks. The calculation is quite simple, just a calculation of zscore=zscore1*weight1+zscore2*weight2....zscoreN*zscoreN, where the zscores are in different sheets and the weights are contained in an array. The code works, but with 500 stocks and 103 periods it takes about 30 seconds to complete. I was looking for advice to speed my code up / make it more "correct" as in terms of good programming practices.

I know my code is a bít messy, but since it works I just hoped I could get some general advice on my way to use loops, if-sentenses and arrays.

Public factor() As Single

Sub zscores()
Dim StartTime As Double, EndTime As Double
Dim sheetNames() As String
Dim r As Integer, i As Integer
Dim antalAktier As Integer, perioder As Integer
Dim zscore As Single
StartTime = Timer

Worksheets("ZScores").Range("B2:AAA1000").ClearContents

'perioder and antalAktier is just variables to determine number of stocks and periods
perioder = Application.WorksheetFunction.CountA(Worksheets("returns").Range("A2:A1500"))
antalAktier = Application.WorksheetFunction.CountA(Worksheets("returns").Range("B1:AAA1"))

'Makes an array of sheetnames
r = 1
i = 0
ReDim sheetNames(0)
Do Until Worksheets("BloomdataFLDS").Cells(r, 1).Value = ""
    sheetNames(i) = Worksheets("BloomdataFLDS").Cells(r, 1).Value
    i = i + 1
    ReDim Preserve sheetNames(i)
    r = r + 1
Loop

'factor() is an array of values from textboxes in a userform
'Code uses the sheetnames array to jump between sheets and making a weighted average of the cell values and factor array values 
k = 2
For k = 2 To antalAktier + 1
    r = 2
    For r = 2 To perioder + 1
        zscore = 0
        For i = 0 To (UBound(factor) - 18)
            zscore = zscore + (factor(i) * Worksheets(sheetNames(i)).Cells(r, k).Value)
        Next i
        'truncates the value to be max/min +/- 3
        If Worksheets("binær").Cells(k, r).Value = 1 And Worksheets("returns").Cells(r, k).Value <> "#N/A N/A" Then
            If zscore < 3 And zscore > -3 Then
                Worksheets("ZScores").Cells(r, k).Value = zscore
            ElseIf zscore < -3 Then
                Worksheets("ZScores").Cells(r, k).Value = -3
            ElseIf zscore > 3 Then
                Worksheets("ZScores").Cells(r, k).Value = 3
            End If
        Else:
            Worksheets("ZScores").Cells(r, k).Value = ""
        End If
    Next r
Next k
EndTime = Timer
MsgBox "Execution time in seconds: " + Format$(EndTime - StartTime)
End Sub

Answer 1

Generally to speed up your code add

Application.ScreenUpdating = False

to the start of your code &

Application.ScreenUpdating = True

to the end.

I would guess that using VBAs Count function will have at least a slightly better performance than Excel's CountA. So instead of

perioder = Application.WorksheetFunction.CountA(Worksheets("returns").Range("A2:A1500"))

you might be better off using

perioder = Worksheets("returns").Range(Range("A2"),Range("A2").end(xlDown)).Count

(I am assuming there should be not gaps considering you're Do Loop ends when the cell is empty).

Multiple ReDims is probably slowing you down so I would remove

ReDim Preserve sheetNames(i)

from your Do Loop & change

ReDim sheetNames(0)

to

ReDim sheetNames(perioder)

Also

If zscore < 3 And zscore > -3 Then
    Worksheets("ZScores").Cells(r, k).Value = zscore
ElseIf zscore < -3 Then
    Worksheets("ZScores").Cells(r, k).Value = -3
ElseIf zscore > 3 Then
    Worksheets("ZScores").Cells(r, k).Value = 3
End If

would be more efficient as

With Worksheets("ZScores").Cells(r, k)
   If zscore < 3 And zscore > -3 Then
       .Value = zscore
   ElseIf zscore < -3 Then
       .Value = -3
   ElseIf zscore > 3 Then
       .Value = 3
   End If
End With

Hope it helps.

Answer 2

The most common way to improve performance is disabling visual feedback. You can just add this in the beginning:

Excel.Application.ScreenUpdating = False
Excel.Application.Calculation = Excel.xlCalculationManual
Excel.Application.EnableEvents = False

And this at the end:

Excel.Application.ScreenUpdating = True
Excel.Application.Calculation = Excel.xlAutomatic
Excel.Application.EnableEvents = True

Also note that ReDim Preserve sheetNames(i) takes a lot of time, too. You can use collections instead of an array.

Answer 3

I'm not sure how much time it will save, but using ReDim and ReDim Preserve can waste a lot of memory (I'm not sure on how many iterations you make, so this will impact the efficiency of using ReDim Preserve).

Each time you perform a ReDim Preserve, the array is taken and then copied, creating a new instance of itself with the resized dimensions. You could perform the section of the code without using ReDim Preserve, like below:

Dim lrow As Long
Dim sheetNames() As Variant

lrow = Cells(Rows.Count, 1).End(xlUp).Row
sheetNames = Sheets("BloomdataFLDS").Range(Cells(1, 1), Cells(lrow, 1)).Value

Unless there's any reason in particular why you don't wish to have a variant 2d array? When assigning an array from a worksheet, it results in a 2d array, even if you only have 1 dimension worth of data. When you iterate through the array, you just have to specify that the 2nd dimension is always '1'.

As I'm writing this @jbmb2000 has already mentioned the efficiencies for the 2nd loop, so I won't continue. Hope this helps though.