VBA Calculation Performance HELP

[Alex Oliveira]

Dear developers,

I have created a VBA application to process commissions and would like your feedback on how I can improve the performance on calculations on 20,000 rows of data. For instance, to calculate product margin I have used application.WorsheetFunction.SumIfs. Below is an image of my code. Has anyone done something similar to this in a more efficient way? Thanks

 

[Hui]

Alex

Firstly, Welcome to the Chandoo.org Forums

Can you please upload a file with the data and VBA or even a small sample

This will assist us to assist you.

 

[Alex Oliveira]

Hui,

Thanks for offering the help. I have attached a sample file where I created 6 versions of the VBA code. Because of size limit, the attached file only contains about 1,000 rows of data where the production files have more than 50k. Essentially I created a system with ACCESS to store sales transactions and EXCEL to pull and process commissions every month for all sales reps. The system takes about 15 minutes to calculate product margin with the approach I have shown you in the file, but I would hope there would be a better way, possibly with arrays. Thanks a lot.

 

[Hui]

Can you please try this code in your real data set
It is slower than your code for 1000 rows, but should be faster on larger data sets

Public Sub Product_Margin()

Columns("AA:AF").ClearContents

startTime = Timer
 
Application.Calculation = xlCalculationManual

 
'DECLARE VARIABLES

Dim criteria1 As Long ' the criteria
Dim criteria2 As String ' the criteria
Dim criteria3 As String ' the criteria

Dim sum1 As Double
Dim sum2 As Double
Dim sum3 As Double

Dim i as long, j as long

LCol = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
LRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
 
'INSERT NEW COLUMN TITLE

Cells(3, LCol + 1).Value = "PRODUCT_MARGIN"

'LOOP THROUGH TRANSACTIONS CALCLATING PRODUCT MARGIN
Dim Arr As Variant
Arr = Range("A4", Cells(LRow, LCol)).Value

Dim pm_Arr As Variant
ReDim pm_Arr(1 To UBound(Arr, 1))

For i = 1 To UBound(Arr, 1)

    criteria1 = Arr(i, 1)  '[ORDERNO]
    criteria2 = Arr(i, 20) '[COMMISSION_BASIS]
    criteria3 = Arr(i, 18) '[FISCAL_MONTH]

    sum1 = 0
    sum2 = 0
    sum3 = 0

    For j = 1 To UBound(Arr, 1)
        If Arr(j, 1) = criteria1 And Arr(j, 20) = criteria2 And Arr(j, 18) = criteria3 Then
          sum1 = sum1 + Arr(j, 6)
          sum2 = sum2 + Arr(j, 25)
        End If
    Next j
         
    sum3 = sum1
 
    If sum3 <> 0 Then
      pm_Arr(i) = ((sum1 - sum2) / sum3)
    Else
      pm_Arr(i) = 0
    End If

Next i

' Save results
Range(Cells(4, LCol + 1), Cells(LRow, LCol + 1)) = Application.WorksheetFunction.Transpose(pm_Arr)
Range(Cells(4, LCol + 1), Cells(LRow, LCol + 1)).NumberFormat = "0.00%"

Application.Calculation = xlCalculationAutomatic

Debug.Print "New Time = ", Timer - startTime
 
End Sub

or see attached file

 

[Alex Oliveira]

Hui, I've implemented your code and tested on the entire data set (49,754 records). The arrays are populated really fast into memory but still took 16 minutes to complete the process and save results back to excel. I'm currently running this on an i7 vPro machine with 32GB of ram, so plenty of power. Performance wise, it's very close to the existing solution I have. Could it be that in the end excel/VBA is just not the right tool for this? Have you done something similar to this in your past projects? Thanks.

 

[Hui]

There’s always more than one way to skin a cat

Let me have another think

 

[NARAYANK991]

Hi ,

Which procedure in your workbook is taking a long time ?

I ran the procedure named PRODUCT_MARGIN_2 , and it took just a second to execute on your data set of 1000 rows ; on 50,000 rows , it should not take 15 minutes.

Can you clarify ?

Narayan

 

[Alex Oliveira]

Hi Narayan, that particular macro completed in 8 minutes on the entire 49,754 rows of data. I'm wondering if this sort of calculation is too much to be handled in excel VBA.

 

[Chihiro]

To accurately measure how long the code itself takes, below line should be above Application.Calculation line.

Debug.Print "New Time = ", Timer - startTime

If there is large disparity between time returned and when workbook is ready. Then it means inefficiency is outside of the code.

Do note, depending on machine, as array size increases, operation can take much longer than anticipated, when compared to same code running on smaller array.

I did run a test on your sample using Hui's code. 1000 record takes 0.6 sec to process on my machine, each loop taking 0.6 milliseconds.

But when record is expanded to 50k, it took 1461.52 sec, each outer loop taking 29.23 milliseconds.

This is due to inner loop also increasing in size from 1000 to 50k. Causing total loop needed to go from 1 million to 2.5 billion.

I'll see if I have time tomorrow to look at the code more in detail.

 

[Chihiro]

Took a quick look. Below should run significantly faster with 50k records. Depending on number of duplicates for criteria 1 to 3.

Public Sub Product_Margin()

Columns("AA:AF").ClearContents

startTime = Timer
   
Application.Calculation = xlCalculationManual

Dim sum1 As Double
Dim sum2 As Double
Dim sum3 As Double
Dim counter As Double

LCol = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
LRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
   
'INSERT NEW COLUMN TITLE

Cells(3, LCol + 1).Value = "PRODUCT_MARGIN"

'LOOP THROUGH TRANSACTIONS CALCLATING PRODUCT MARGIN
Dim ord_Arr, com_Arr, fis_Arr
Dim sum_1 As Range, sum_2 As Range
ord_Arr = Range("A4:A" & LRow).Value
com_Arr = Range("T4:T" & LRow).Value
fis_Arr = Range("R4:R" & LRow).Value

Set sum_1 = Range("F4:F" & LRow)
Set sum_2 = Range("Y4:Y" & LRow)



With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(ord_Arr)
        x = Join(Array(ord_Arr(i, 1), com_Arr(i, 1), fis_Arr(i, 1)), ",")
        If Not .Exists(x) Then
            sum1 = Application.SumIfs(sum_1, Range("A4:A" & LRow), ord_Arr(i, 1), Range("T4:T" & LRow), com_Arr(i, 1), Range("R4:R" & LRow), fis_Arr(i, 1))
            sum2 = Application.SumIfs(sum_2, Range("A4:A" & LRow), ord_Arr(i, 1), Range("T4:T" & LRow), com_Arr(i, 1), Range("R4:R" & LRow), fis_Arr(i, 1))
            sum3 = sum1
            If sum3 = 0 Then
                .Item(x) = 0
            Else
                .Item(x) = (sum1 - sum2) / sum3
            End If
        End If
    Next

    Dim pm_Arr As Variant
    ReDim pm_Arr(1 To UBound(ord_Arr), 1 To 1)
    For i = 1 To UBound(ord_Arr)
        x = Join(Array(ord_Arr(i, 1), com_Arr(i, 1), fis_Arr(i, 1)), ",")
        pm_Arr(i, 1) = .Item(x)
    Next
End With

' Save results
Cells(4, LCol + 1).Resize(UBound(pm_Arr), 1) = pm_Arr
Range(Cells(4, LCol + 1), Cells(LRow, LCol + 1)).NumberFormat = "0.00%"
Debug.Print "New Time = ", Timer - startTime
Application.Calculation = xlCalculationAutomatic

End Sub

 

[Alex Oliveira]

Chihiro,

I just ran your code and finished processing in 3:50:18 secs. This is amazingly fast compared to what I have running in production. It's going to take me a while to really understand all that's going on in your code, but I'm excited to implement this tomorrow in the full system and see the improvements. Thanks very much for your help.