Excel 需要很长时间来计算 UDF VBA

Question

我要匹配的文件名在 A 行，我正在查看第 I 行是否有匹配项其图像文件名的行。 这段代码有效，但是，当我运行它时存在一个问题，即使只计算 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

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

    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

Answer 2

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

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

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 function 的第二个版本，它直接将值输出到Collection中。 然后，您可以更改CountMatchingElements以接受集合，并且不需要将第二个数组转换为集合。

我将把它作为一个想法供你试验。

Answer 3

不确定这会快多少（因为我这样做主要是为了了解您在做什么。
一旦发布了一些数据，它应该会更快一些，并且可以进行改进以进一步提高性能。

'Name function and arguments
Function SearchChars(lookup_value As String, tbl_array As Range) As String
    
    'Declare variables and types
    Dim stVal$, stReturn$
    Dim inCharPos%, inMatchedPos%, inCountMatched%, inBestMatch%, vnCellVal
    Dim lgAR&, varDataValues()
    
    varDataValues = tbl_array.Value
    
    'Iterate through each cell
    For Each vnCellVal In varDataValues: inCountMatched = 0
      
      'Get cell value as a string (stVal)
      stVal = vnCellVal
      
        'Iterate through characters in lookup_value
        For inCharPos = 1 To Len(lookup_value)
        
            'Check is cell has any char matching this char of lookup_value?
            inMatchedPos = InStr(vnCellVal, Mid(lookup_value, inCharPos, 1))
            If inMatchedPos > 0 Then
            
                'Count number of matches
                inCountMatched = inCountMatched + 1
            
                'Remove matched char from cell value and continue
                vnCellVal = Left(vnCellVal, inMatchedPos - 1) & Mid(vnCellVal, inMatchedPos + 1, 9999)
            
            End If
        
        'Next character
        Next inCharPos
     
        'Reduce matched value by number of unmatched chars (not sure why)
        inCountMatched = inCountMatched - Len(vnCellVal)
        
        'Save return value if this is the best match so far
        If inCountMatched > inBestMatch Then
            inBestMatch = inCountMatched
            stReturn = stVal
        End If
     
    Next vnCellVal
    
    'Return value with the most matching characters
    SearchChars = stReturn

End Function