Excel 需要很长时间才能计算 UDF VBA

Question

example2 example1 The file name I'm trying to match is on Row A and I'm looking through Row I to see if there is a match 我找到了这段代码，我不记得在哪里，但我试图将一行零件号与其图像文件名的一行匹配。这段代码有效，但是，当我运行它时存在一个问题，即使只计算 1 列也需要很长时间，当我一次执行数百个时，我的 excel 只是停止响应，并且我需要匹配数千种产品。我对 VBA 很陌生，所以我什至无法找出问题所在。

请帮忙，谢谢。

'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
'Declare variables and types
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
'Iterste through each cell
For Each cell In tbl_array
  'Save cell value to variable
  str = cell
  'Iterate through characters
  For i = 1 To Len(lookup_value)
    'Same character?
    If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
      'Add 1 to number in array
      a = a + 1
      'Remove evaluated character from cell and contine with remaning characters
      cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
    End If
  'Next character
  Next i
 
a = a - Len(cell)
'Save value if there are more matching characters than before  
If a > b Then
  b = a
  Value = str
End If
 
a = 0
Next cell
'Return value with the most matching characters
SearchChars = Value
End Function

Answer 1

编辑（查看数据后）：以下应该明显更快（并且明显更简单）

'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
    
    'Declare variables and types
    Dim inLenMatched%, vnVal, varLookupValues()
    
    'Puts lookup cell values into a array (to speed things up)
    varLookupValues = tbl_array.Value
    
    'Iterate through each lookup value
    For Each vnVal In varLookupValues
      
        'Ignore empty cells
        If vnVal <> "" Then
            
            'Does part number appear in filename?
            If InStr(lookup_value, vnVal) > 0 Then
                
                'Is this match the most complete match so far?
                If Len(vnVal) > inLenMatched Then
                    inLenMatched = Len(vnVal)
                    SearchChars = vnVal
                End If
             End If
        End If
        
    Next vnVal
    
    'Return match value (or 'No Match' if not matched)
    If SearchChars = "" Then SearchChars = "No Match"

End Function

以上只是一种现成的方法。
还有其他（并且可能更快）的方法来解决这个问题。

提高性能的最明显步骤（无论采用何种方法）是将tbl_array 限制为仅包含数据的行（而不是整个列）。

另外：如果不知道所有可能的情况，就不可能肯定地说。但是，这很可能可以使用本机 excel 函数来完成，并且（如果是的话）将提供最佳性能。

Answer 2

我试图修改您现有的代码，但我发现使用我认为更好的结构重写它更容易。并且在运行代码超过 26 列和 432 行后，只需 0.2 秒即可找到最接近的匹配字符串。

我将每个值都移到了一个数组中。 我将lookup_value 和“单元格值”转换为字节数组。 我比较了字节数组来计算匹配的“字符”。 然后我返回匹配“字符”数量最多的字符串。

Sub Example()
    Dim StartTime As Double
    StartTime = Timer * 1000
    Debug.Print SearchChars3("Toddleson", Range("A1:Z432"))
    Debug.Print "Time Elapsed: " & Timer * 1000 - StartTime & " ms"
    'Time Elapsed: 171.875 ms
End Sub

Function SearchChars3(lookup_value As String, tbl_array As Range) As String
    Dim ClosestMatch As String, HighestMatchCount As Integer
    
    Dim tbl_values() As Variant
    tbl_values = tbl_array.Value
    
    Dim LkUpVal_Bytes() As Byte
    LkUpVal_Bytes = ToBytes(lookup_value)
    
    Dim Val As Variant
    For Each Val In tbl_values
        If Val = "" Then GoTo nextVal
        
        Dim Val_Bytes() As Byte
        Val_Bytes = ToBytes(CStr(Val))
        
        Dim MatchCount As Integer
        MatchCount = CountMatchingElements(LkUpVal_Bytes, Val_Bytes)
        
        If MatchCount > HighestMatchCount Then
            HighestMatchCount = MatchCount
            ClosestMatch = Val
        End If
nextVal:
    Next
    SearchChars3 = ClosestMatch
End Function

Function ToBytes(InputStr As String) As Byte()
    Dim ByteArr() As Byte
    ReDim ByteArr(Len(InputStr) - 1)
    Dim i As Long
    For i = 0 To Len(InputStr) - 1
        ByteArr(i) = AscW(Mid(InputStr, i + 1, 1))
    Next
    ToBytes = ByteArr
End Function

Function CountMatchingElements(Arr1 As Variant, Arr2 As Variant) As Integer
    'As elements from Arr1 are found in Arr2, those elements are removed from Arr2, to prevent re-matching with the same elements
    'To enable this feature, Arr2 is turned into a Collection
    Dim Col2 As New Collection
    Dim v As Variant
    For Each v In Arr2
        Col2.Add v
    Next
    
    Dim MatchCount As Integer, i As Long
    For Each v In Arr1
        For i = 1 To Col2.Count
            If Col2.Item(i) = v Then
                MatchCount = MatchCount + 1
                Col2.Remove (i)
                Exit For
            End If
        Next
    Next
    CountMatchingElements = MatchCount
End Function

进一步的优化可能是有第二个版本的ToBytes 函数，它直接将值输出到Collection。然后，您可以将CountMatchingElements 更改为接受集合，并且不需要将第二个数组转换为集合。

我将把它留作你试验的想法。

Answer 3

如前所述，通过将范围分配给数组来最小化与工作表的交互将在结构上使您的宏更快。 未经测试，但您的代码中的这些细微更改应该可以帮助您走上正轨：

    Option Explicit
    'Name function and arguments
    Function SearchChars2(lookup_value As String, tbl_array As Range) As String
    'Declare variables and types
    Dim i As Integer, str As String, Value As String
    Dim a As Integer, b As Integer, cell As Variant
    'Iterste through each cell => replace with array
    'adapt to correct sheet
    Dim arr
    arr = tbl_array
    
    For Each cell In arr 'tbl_array
        'Save cell value to variable
        str = cell
        'Iterate through characters
        For i = 1 To Len(lookup_value)
          'Same character?
          If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
            'Add 1 to number in array
            a = a + 1
            'Remove evaluated character from cell and contine with remaning characters
            cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
          End If
        'Next character
        Next i
     
        a = a - Len(cell)
        'Save value if there are more matching characters than before
        If a > b Then
          b = a
          Value = str
        End If
         
        a = 0
        Next cell
    'Return value with the most matching characters
    SearchChars2 = Value
    End Function