Home » excel » excel – Identify VBA UDF Bottlneck

excel – Identify VBA UDF Bottlneck

Posted by: admin May 14, 2020 Leave a comment


In my worksheet, I have four different categories. For each category, there are
3~5 different prices. There are other attributes as well. As a result, each categories are duplicated many times and there are 30,000 rows in total. The first row of the worksheet have all the column names. Each category spans over consecutive rows. Therefore, I wrote the following function to identify “blocks” and calculate the min of the “blocks”.

Example Image of How Cat Blocks Look Like

    Public Function blockMin(rng_temp As Range) As Integer

        Dim currRow As Long
        currRow = rng_temp.Row

        'Find Category col
        Dim rng As Range
        Dim cabin_col As Long
        Dim price_col As Long

        For Each rng In Range("1:1")
            If rng.Value = "Cat" Then
                cat_col = rng.Column
            End If
            If rng.Value = "Price" Then
                pric_col = rng.Column
            End If
        Next rng

        Dim cat_col_char, price_col As String
        cat_col_char = Number2Letter(cat_col)
        price_col_char = Number2Letter(price_col)

        ' Find last row of the usedRange    
        Dim lastRow As Long
        lastRow = findLastRow()

        'Where the block is for each cat
        Dim startRow, endRow As Long
        startRow = rng_temp.Row
        endRow = rng_temp.Row

         'Find Top
        Do While startRow >= 2
            If Range(cat_col_char & startRow).Value <> Range(cat_col_char & currRow) Then
                startRow = startRow + 1
                Exit Do
            End If
            startRow = startRow - 1

        If startRow = 1 Then startRow = 2   ' at the very top

         'Find Bottom
        Do While endRow <= lastRow - 1
            If Range(cat_col_char & endRow).Value <> Range(cat_col_char & currRow) Then
                endRow = endRow - 1
                Exit Do
            End If
            endRow = endRow + 1

        If endRow = lastRow - 1 Then endRow = lastRow ' at the very bottom

        'Return min of the block
        Dim block As Range
        Set block = Range(price_col_char & startRow & ":" & price_col_char & endRow)

        blockMin = Application.WorksheetFunction.Min(block)

    End Function

When I call the formula for a single cell, it is pretty fast. However, I have to call the UDF for 30,000 cells and that takes up to five minutes for every single calculation refresh. I was wondering if there are some room of improvements for run-time. Or, if there is a better way to work around it with built-in formula.

Thank you so much.

How to&Answers:

Something like this would be a little faster:

Public Function blockMin(rng_temp As Range) As Integer 'double?

    Dim sht As Worksheet, rS As Long, rE As Long, cat, v
    Dim hdrs, i As Long
    Dim cat_col As Long, price_col As Long

    Set sht = rng_temp.Worksheet '<<< scope all references to this sheet
                                 ' or you'll get odd results when a different
                                 ' sheet is active
    rS = rng_temp.Row
    rE = rS

    'Find headers
    hdrs = sht.Range("A1").Resize(1, 100).Value 'limit your search range
    For i = 1 To UBound(hdrs, 2)
        v = hdrs(1, i)

        If cat_col = 0 And v = "Cat" Then cat_col = i
        If price_col = 0 And v = "Price" Then price_col = i

        If cat_col > 0 And price_col > 0 Then
            cat = rng_temp.EntireRow.Cells(cat_col).Value
            If Len(cat) > 0 Then
                'find start/end rows
                Do While rS > 1 And sht.Cells(rS, cat_col) = cat
                    rS = rS - 1
                Do While sht.Cells(rE, cat_col) = cat
                    rE = rE + 1

                blockMin = Application.Min(sht.Range(sht.Cells(rS + 1, price_col), _
                                                     sht.Cells(rE - 1, price_col)))
            End If
            Exit For
        End If
    Next i

End Function