Excel taking really long to calculate a UDF VBA - excel

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

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.

Answer 2

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 3

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.