Excel taking really long to calculate a UDF VBA-CodePudding

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 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

CodePudding user response：

EDIT (post seeing the data): The following should be notably faster (as well as notably simpler)

'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

The above is just one off-the-cuff approach.
There are other (and quite possible faster) ways to approach this.

The most obvious step (regardless of method) to improving performance would be to limit tbl_array to only the rows with data (not the entire column).

Separately: Without knowing all possible cases, it's impossible to say for sure. But, in all probability, this can be done with Native excel functions, and (if so) that will deliver the best performance.

CodePudding user response：

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

CodePudding user response：

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.