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

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

Have you tried storing your `range.values` as an array then using `InStr()`, loop through your array (all in VBA, which will make things faster), and record your string `ConcatIf` to append after the VBA stuffs? — Cyril, May 20 '19 at 14:26
I would throw sheet1 into 1 array, and the values in sheet2 into a dictionary, then use the [answers](https://stackoverflow.com/questions/28246074/wildcard-search-of-dictionary) here to check for partial matches. — Damian, May 20 '19 at 14:28

score 0 · Answer 1 · answered May 20 '19 at 15:56

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

score 0 · Answer 2 · answered May 20 '19 at 17:05

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

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

2 Answers2