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

Question

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 I found this code I can't recall where but I am trying to match row of part numbers to a row of its image file names. This code works, however, there is a problem when I run it it takes really long to calculate even just 1 column and when I do hundreds at a time my excel just stops responding, and I have thousands of products I need to match. I am really new with VBA so I can't even figure out the problem.

Please help, thank you.

'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

As said, minimizing the interactions with the sheet by assigning the range to an array will structurally make your macros faster. Not tested but these minor changes in your code should help you on the right track:

    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

I was trying to modify your existing code, but I found it easier to just rewrite it using what I consider to be a better structure. And After running the code over 26 columns & 432 rows, It only took 0.2 seconds to find the Closest Matching String.

I moved every value into an array. I converted the lookup_value and the "cell values" into an array of bytes. I compared the byte arrays to count matching "characters". And then I return the string that had the highest number of matching "characters".

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

A further optimization could be to have a second version of the ToBytes function that directly outputs the values into a Collection . Then, you can change CountMatchingElements to accept a collection and it wont need to convert the second array into a collection.

I will leave that as an idea for you to experiment with.

Answer 3

Not sure how much faster this would be (as I did it mainly to understand what you're doing.
It should be a little faster and can be refined for further performance improvements, once you post some data.

'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