How to increase the performance of a partial match lookup function? - excel

Question

The current performance of this function is to slow, currently I am working with a list of 500+ item codes on sheet1. The function searches in a range of 200 000 + items on sheet2 to find all matches including partial matches. This means that we include a wildcards before and after the lookup criteria to find all matches.
Currently it takes over 15 mins to complete. Is there a better method to do this? To get this under 5 mins?
Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
Optional ByVal stringsRange As Range, Optional Delimiter As String) As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim i As Long, j As Long, criteriaMet As Boolean
Set compareRange = Application.Intersect(compareRange, _
compareRange.Parent.UsedRange)
If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - _
compareRange.Row, stringsRange.Column - compareRange.Column)
For i = 1 To compareRange.Rows.Count
For j = 1 To compareRange.Columns.Count
If (Application.CountIf(compareRange.Cells(i, j), _
xCriteria)= 1) Then
ConcatIf = ConcatIf & Delimiter & _
CStr(stringsRange.Cells(i, j))
End If
Next j
Next i
ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Function
Example:
+500 ITEM CODES
Sheet1:
BCD
CDF
XLMH
XPT
ZPY
200 000 + FULL ITEM CODES
Sheet2:
FDBCDGH
HSGDBCDSU
GFD-CDFGDTR
SBGCDFHUD
GKJYCDFFDS
DDFGFDXLMHGFD
SDGXLMHSDFS
SDGVSDXLMHFAMN
DDDSXPTDFGFD
JUYXPTFADS
DDDFFZPYDGDFDF
Outcome should be:
Sheet1:
COLUMN A - COLUMN B
BCD - FDBCDGH,HSGDBCDSU
CDF - GFD-CDFGDTR,SBGCDFHUD,GKJYCDFFDS
XLMH - DDFGFDXLMHGFD,SDGXLMHSDFS,SDGVSDXLMHFAMN
XPT - DDDSXPTDFGFD,JUYXPTFADS
ZPY - DDDFFZPYDGDFDF

Answer 1

To use the following code you will need to add a reference to Microsoft Scripting Runtime. This uses two arrays and compiles the data in a dictionary. This can then be written back to your sheet. The code currently writes the results back to the immediate window which can be displayed using Ctrl+G or View->Immediate Window
Public Sub demo()
Dim compArr As Variant, strArr As Variant
Dim strDict As Dictionary
Dim i As Long
Dim Delimiter As String: Delimiter = "; "
Dim key
' Set data to arrays. This assumes your data is in column A
With Sheets("Sheet1")
' Application.Transpose is a trick to convert the range to a 1D array (otherwise a 2D array will be created)
compArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
End With
With Sheets("Sheet2")
strArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
End With
' Initiate dictionary
Set strDict = New Dictionary
' Loop through all the values you wish to find
For i = LBound(compArr) To UBound(compArr)
' Tests if value exists
If Not strDict.Exists(compArr(i)) Then
' Adds value to dictionary and uses filter on string array to get similar matches.
' Join is used to convert the resulting array into a string
strDict.Add key:=compArr(i), Item:=Join(Filter(strArr, compArr(i), True), Delimiter)
End If
Next i
' Read back results
For Each key In strDict.Keys
Debug.Print key, strDict(key)
Next key
End Sub

Answer 2

To maintain all of your current functionality and useability regarding the size of your dataset, this should work for you and be faster than the original code. When I timed it, I used 400,000 full item codes and applied the concatif formula on sheet 1 for 1000 partial matches and it completed all cell calculations in under 9 minutes.
Public Function CONCATIF(ByVal arg_rCompare As Range, _
ByVal arg_vCriteria As Variant, _
Optional ByVal arg_rStrings As Range, _
Optional ByVal arg_sDelimiter As String = vbNullString _
) As Variant
Dim aData As Variant
Dim aStrings As Variant
Dim aCriteria As Variant
Dim vString As Variant
Dim vCriteria As Variant
Dim aResults() As String
Dim ixResult As Long
Dim i As Long, j As Long
If arg_rStrings Is Nothing Then Set arg_rStrings = arg_rCompare
If arg_rStrings.Rows.Count <> arg_rCompare.Rows.Count _
Or arg_rStrings.Columns.Count <> arg_rCompare.Columns.Count Then
CONCATIF = CVErr(xlErrRef)
Exit Function
End If
If arg_rCompare.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = arg_rCompare.Value
Else
aData = arg_rCompare.Value
End If
If arg_rStrings.Cells.Count = 1 Then
ReDim aStrings(1 To 1, 1 To 1)
aStrings(1, 1) = arg_rStrings.Value
Else
aStrings = arg_rStrings.Value
End If
If IsArray(arg_vCriteria) Then
aCriteria = arg_vCriteria
ElseIf TypeName(arg_vCriteria) = "Range" Then
If arg_vCriteria.Cells.Count = 1 Then
ReDim aCriteria(1 To 1)
aCriteria(1) = arg_vCriteria.Value
Else
aCriteria = arg_vCriteria.Value
End If
Else
ReDim aCriteria(1 To 1)
aCriteria(1) = arg_vCriteria
End If
ReDim aResults(1 To arg_rCompare.Cells.Count)
ixResult = 0
For i = LBound(aData, 1) To UBound(aData, 1)
For j = LBound(aData, 2) To UBound(aData, 2)
For Each vCriteria In aCriteria
If aData(i, j) Like vCriteria Then
ixResult = ixResult + 1
aResults(ixResult) = aStrings(i, j)
End If
Next vCriteria
Next j
Next i
If ixResult > 0 Then
ReDim Preserve aResults(1 To ixResult)
CONCATIF = Join(aResults, arg_sDelimiter)
Else
CONCATIF = vbNullString
End If
Erase aData: aData = vbNullString
Erase aCriteria: aCriteria = vbNullString
Erase aResults
End Function