I am looking for some tips to improve my vba code's performance or hoping that someone would spot what my issue is, as I can't figure out myself.
What the code should do:
The code works. It does what I want, but it is extremely slow. Adding the buckets for around 100 items take ~22 seconds. At 2000 items it's already 7 minutes. However there can be scenarios where I would need to put buckets next to 128 000 entries. However I know that this could be resolved with simple formulas, but the data table is already huge (2000 lines and 400 columns) with a lot of calculated columns.
I read that newer versions of excel have performance issues when need to access cells in tables but couldn't find a proper solution anywhere. Appreciate any tips and tricks.
Things I tried already (but nothing improved the results significantly):
See below my code snippet and let me know if you would like to have any additional info.
Sub Buckets()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim conf As Worksheet
Dim rcount As Long
Dim bucket1 As String
Dim bucket2 As String
Dim bucket3 As String
Dim bucket4 As String
Dim bucket5 As String
Dim bucket6 As String
Dim bucket7 As String
Dim bucket8 As String
Dim lim As Integer
Dim lim1 As Integer
Dim lim2 As Integer
Dim lim3 As Integer
Dim lim4 As Integer
Dim lim5 As Integer
Dim lim6 As Integer
Dim number As Double
Dim ScenNo As Integer
Dim Datarange As Range
Dim Bucketrange As Range
Dim i As Integer
Set conf = Worksheets("Config")
Set ws = Worksheets("DATABASE")
Set Datarange = ws.Range("A9:A2008")
Set Bucketrange = ws.Range("B9:B2008")
rcount = ws.ListObjects("TABLE").ListColumns(7).Range.Find("*", searchorder:=xlByRows, LookIn:=xlValues, searchdirection:=xlPrevious).Row
'B54 to B60 contains numbers from 15 up to 90 with a step of 15 minutes. The top value is 1000
With conf
bucket1 = "Below " & .Range("B54").Value2 & " minutes"
bucket2 = "Between " & .Range("B54").Value2 & " and " & .Range("B55").Value2 & " minutes"
bucket3 = "Between " & .Range("B55").Value2 & " and " & .Range("B56").Value2 & " minutes"
bucket4 = "Between " & .Range("B56").Value2 & " and " & .Range("B57").Value2 & " minutes"
bucket5 = "Between " & .Range("B57").Value2 & " and " & .Range("B58").Value2 & " minutes"
bucket6 = "Between " & .Range("B58").Value2 & " and " & .Range("B59").Value2 & " minutes"
bucket7 = "Between " & .Range("B59").Value2 & " and " & .Range("B60").Value2 & " minutes"
bucket8 = "Above " & .Range("B60").Value2 & " minutes"
lim = .Range("B54").Value2
lim1 = .Range("B55").Value2
lim2 = .Range("B56").Value2
lim3 = .Range("B57").Value2
lim4 = .Range("B58").Value2
lim5 = .Range("B59").Value2
lim6 = .Range("B60").Value2
End With
For i = 9 To rcount
If Cells(i, 16) = "" Or Cells(i, 16) = "Exclude" Then 'y - 1
GoTo SKIPSTEP
End If
number = Datarange(i - 8, 1).Value2 'y - 1
If number < lim Then
Bucketrange(i - 8, 1) = Buckets(1, 1).Value2
ElseIf number >= lim And number < lim1 Then
Bucketrange(i - 8, 1) = Buckets(2, 1).Value2
ElseIf number >= lim1 And number < lim2 Then
Bucketrange(i - 8, 1) = Buckets(3, 1).Value2
ElseIf number >= lim2 And number < lim3 Then
Bucketrange(i - 8, 1) = Buckets(4, 1).Value2
ElseIf number >= lim3 And number < lim4 Then
Bucketrange(i - 8, 1) = Buckets(5, 1).Value2
ElseIf number >= lim4 And number < lim5 Then
Bucketrange(i - 8, 1) = Buckets(6, 1).Value2
ElseIf number >= lim5 And number < lim6 Then
Bucketrange(i - 8, 1) = Buckets(7, 1).Value2
Else
Bucketrange(i - 8, 1) = Buckets(8, 1).Value2
End If
SKIPSTEP:
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
Thanks to @Rory I loaded the numbers into an array and now it runs in 1.2 seconds instead of 7 minutes. See below a simplified version of the code snippet. I understand that there might be some additional improvements to this. I will edit my answer once I could tidy up the code a bit. Million thanks to @Rory and hope this will help others as well.
Sub Buckets()
Dim starttime As Double
Dim finish As Double
Dim endtime As Double
starttime = Timer()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim conf As Worksheet
Dim rcount As Long
Dim bucket1 As String
Dim bucket2 As String
Dim bucket3 As String
Dim bucket4 As String
Dim bucket5 As String
Dim bucket6 As String
Dim bucket7 As String
Dim bucket8 As String
Dim lim As Integer
Dim lim1 As Integer
Dim lim2 As Integer
Dim lim3 As Integer
Dim lim4 As Integer
Dim lim5 As Integer
Dim lim6 As Integer
Dim number As Double
Dim ScenNo As Integer
Dim x As Integer
Dim y As Integer
Dim Datarange() As Double
Dim Bucketrange() As String
Dim cell As Range
Set conf = Worksheets("Config")
With conf
bucket1 = "Below " & .Range("B54").Value2 & " minutes"
bucket2 = "Between " & .Range("B54").Value2 & " and " & .Range("B55").Value2 & " minutes"
bucket3 = "Between " & .Range("B55").Value2 & " and " & .Range("B56").Value2 & " minutes"
bucket4 = "Between " & .Range("B56").Value2 & " and " & .Range("B57").Value2 & " minutes"
bucket5 = "Between " & .Range("B57").Value2 & " and " & .Range("B58").Value2 & " minutes"
bucket6 = "Between " & .Range("B58").Value2 & " and " & .Range("B59").Value2 & " minutes"
bucket7 = "Between " & .Range("B59").Value2 & " and " & .Range("B60").Value2 & " minutes"
bucket8 = "Above " & .Range("B60").Value2 & " minutes"
lim = .Range("B54").Value2
lim1 = .Range("B55").Value2
lim2 = .Range("B56").Value2
lim3 = .Range("B57").Value2
lim4 = .Range("B58").Value2
lim5 = .Range("B59").Value2
lim6 = .Range("B60").Value2
End With
Set ws = Worksheets("DATABASE")
x = 0
For Each cell In ws.Range("R9:R2008")
ReDim Preserve Datarange(x)
Datarange(x) = cell.Value2
x = x + 1
Next cell
x = 0
Dim i As Variant
y = 0
For Each i In Datarange
If i < lim Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket1
y = y + 1
ElseIf i >= lim And i < lim1 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket2
y = y + 1
ElseIf i >= lim1 And i < lim2 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket3
y = y + 1
ElseIf i >= lim2 And i < lim3 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket4
y = y + 1
ElseIf i >= lim3 And i < lim4 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket5
y = y + 1
ElseIf i >= lim4 And i < lim5 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket6
y = y + 1
ElseIf i >= lim5 And i < lim6 Then
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket7
y = y + 1
Else
ReDim Preserve Bucketrange(y)
Bucketrange(y) = bucket8
y = y + 1
End If
Next i
ws.Range("S9:S2008") = Application.Transpose(Bucketrange)
Erase Datarange
Erase Bucketrange
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub