Speeding up VBA Function to Find Sub String in a Range-CodePudding

I need some help with formula I've been working on in Excel. I am trying to categorize descriptions in an Excel file using a reference table and am running into some difficulties.

Here is an example, I have this description below.

"Transfer to DDA Acct No. 135399744-D"

I have created a reference table that shows: "Transfer to DDA Acct No" = "ZBA Transfer"

The issue is that the numbers at the end change so I cannot make an exact match for these references in a table. Additionally the length of these references vary so I cannot just do a vlookup using a MID() or LEFT().

I came up with this formula below that works perfect, the problem is when you do this for 30,000 lines, the file is almost unuseable.

{VLOOKUP(INDEX(ref!$A$1:$A$250,MATCH(1,ISNUMBER(SEARCH(ref!$A$1:$A$250,E2))*1,0)),ref!$A:$B,2,0)}

Where ref!$A$1:$B$250 is the reference table and E2 is the full description

Additionally I came up with a custom function that does the same thing, but again the file is completely unusable.

Function BankRef(BankDescrip As String) 'As Final Value

Dim wb As Workbook
Dim CurrSht, RefSht As Worksheet
Dim testval As String
Dim ShtRow, testval2 As Long

Set wb = ThisWorkbook
Set RefSht = wb.Sheets("ref")
Set CurrSht = wb.Sheets("Bank Stmt")

For i = 2 To 250

Dim DescArray As Variant
DescArray = RefSht.Range("A1:A250").Value
testval = DescArray(i, 1)

testval2 = InStr(BankDescrip, testval)

If testval2 > 0 Then
    ShtRow = RefSht.Range("A:A").Find(What:=testval, LookIn:=xlValues).Row
    BankRef = RefSht.Range("B" & ShtRow).Value
    Exit For
    Else: BankRef = "Not Found"
End If

Next i
End Function

I like the idea of the custom function because it's not constantly trying to recalculate. But I need something more efficient.

Is there a way to do something similar to InStr() but have it search a range instead of just a string and have it return the row number?

CodePudding user response：

Your function could be shortened by eliminating the VLOOKUP(), i.e.

=INDEX(ref!B1:B250,MATCH(1,--ISNUMBER(SEARCH(ref!A1:A250,E2)),0))

To avoid using a loop you can incorporate this formula in an EVALUATE() construct, e.g.

Function BankRef(BankDescrip As Range) As String
    Dim result
    result = BankDescrip.Parent.Evaluate("INDEX(ref!B1:B250,MATCH(1,--ISNUMBER(SEARCH(ref!A1:A250," & BankDescrip.Address & ")),0))")
    If IsEmpty(result) Then
        BankRef = "Description not found"
    Else
        BankRef = result
    End If
End Function

but this is probably less performant than a loop-based approach

Function BankRef(BankDescrip As Range) As String
    Dim arr, curVal As String, i As Long
    arr = Worksheets("ref").Range("A1:B250").Value2
    curVal = BankDescrip.Value2
    For i = 1 To UBound(arr, 1)
        If InStr(1, curVal, arr(i, 1)) Then
            BankRef = arr(i, 2)
            Exit Function
        End If
    Next i
    BankRef = "Description not Found"
End Function

CodePudding user response：

Here's a version (BankRef2) of your function optimized for faster performance, using a Dictionary to cache results so the loop is not repeated if the search value has already been seen. It runs about 10x faster. It does only read your lookup table on the first run, so if you alter the lookup table you'd need to reset your vb project to clear the static variables.

Function tester()
    Dim s As String, ans, i As Long, t
    
    t = Timer
    For i = 1 To 50000
        s = "This is some blah blah " & Format(Application.RandBetween(1, 250), "0000")
        'ans = BankRef(s)   '~7.5 sec
        ans = BankRef2(s)   '~0.6 sec
        If i < 3 Then Debug.Print ans
    Next i
    Debug.Print "not optimized", Timer - t
    
End Function

'non-optimized version
Function BankRef(BankDescrip As String) 'As Final Value
    Dim i As Long, arr
    arr = ThisWorkbook.Sheets("ref").Range("A1:B250").Value
    BankRef = "Not found" 'default value
    For i = 1 To 250
        If InStr(1, arr(i, 1), BankDescrip) > 0 Then
            BankRef = arr(i, 2)
            Exit For
        End If
    Next i
End Function

'optimized version
Function BankRef2(BankDescrip As String) 'As Final Value
    Dim i As Long
    Static arr, dict As Object
    'one-time setup
    If IsEmpty(arr) Then
        Debug.Print "setting up"
        arr = ThisWorkbook.Sheets("ref").Range("A1:B250").Value
        Set dict = CreateObject("scripting.dictionary")
    End If
    'already looked this value up?
    If dict.Exists(BankDescrip) Then
        BankRef2 = dict(BankDescrip)
        Exit Function
    End If
    'not seen before - check...
    BankRef2 = "Not found" 'default value
    For i = 1 To 250
        If InStr(1, arr(i, 1), BankDescrip) > 0 Then
            BankRef2 = arr(i, 2)
            Exit For
        End If
    Next i
    dict.Add BankDescrip, BankRef2 'cache the result
End Function

My test lookup table: