加速VBA功能以在范围内找到子字符串

Question

我需要一些我一直在Excel工作的公式方面的帮助。我正在尝试使用参考表在Excel文件中对描述进行分类，并遇到一些困难。

这是一个示例，我在下面有此描述。

“转移到DDA ACCT编号135399744-D”

我创建了一个参考表，显示： “转移到dda acct no” =“ ZBA传输”

问题是最终的数字变化，因此我无法在表中的这些引用中确切匹配。此外，这些参考的长度各不相同，因此我不能仅使用MID（）或左（）进行VlookUp。

我想到了下面的这个公式，问题是当您以30,000行这样的方式执行此操作时，该文件几乎无法使用。

{vlookup（index（ref！$ a $ 1：$ a $ a $ 250，匹配（1，isnumber）（search（ref！$ a $ 1：$ a $ a $ a $ 250，e2））*1,0）），ref！$ a ：$ b，2,0）}

其中ref！$ a $ 1：$ b $ 250是参考表，e2是完整的

描述我想出了一个自定义功能，可以执行相同的操作，但是文件又完全无法使用。

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

我喜欢自定义功能的想法，因为它不是不断尝试重新计算的。但是我需要更有效的东西。

有没有办法做类似于inser（）类似的事情，但是它是否搜索一个范围而不仅仅是字符串并返回行号？

Answer 1

可以通过消除vlookup（），即

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

避免使用循环您 can can 将此公式纳入evaliate（） construct> construct> 来缩短您的函数。 ，例如

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

，这可能比基于循环的方法少

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

Answer 2

这是您的功能的版本（bankRef2），以更快的性能优化，使用字典来缓存结果，因此如果已经看到搜索值，则不会重复循环。它运行速度约为10倍。它确实仅在第一次运行中读取查找表，因此，如果您更改查找表，则需要重置VB项目以清除静态变量。

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

我的测试查找表：