Advise on making UDF more efficient

[peejay]

Hi

I'm helping a colleague solve a time consuming problem by writing them a UDF.
The UDF shown below takes a string, searches each cell in a range, and builds a comma separated list of all the cell values (in a correspoinding range) containing the search string. The result string is stored in the function's cell.

The function works, but for a long lookup list (40,000 rows) it takes a number of seconds to recalculate a single formula using the function.

I'm hoping for suggestions on how to speed the function up, as we'd need to copy the function across a couple of hundred cells.

Thx

Example:

A1 Bottom
A2 Top
A3 Tomorrow
A4 Today
A5 Atombomb

Formula: =SearchList("Tom", A1:A5)
Result: Bottom, Tomorrow, Atombomb


Public Function SearchList(strSearch As String, _
rngLookup As Range, _
Optional rngValues As Range) As String
'This function uses a search value to search a range of cell values for a match,
'and if a match is found a value is appended to a comma separated string.
'
'This function is passed 3 parameters:
' 1) a search string, used to search the value in each cell in a lookup range;
' 2) a cell range of values to lookup; and
' 3) a cell range of the values to store when a match is made to a lookup cell
'If the Lookup and value ranges are the same, the rngValues parameter can be
'omitted.
'===============================================================================
Dim r As Long 'number of rows in the range
Dim c As Long 'number of columns in the range
Dim n As Long 'number of cells in the range
Dim i As Long 'loop counters for rows
Dim j As Long 'loop counter for columns
Dim rng As Range 'lookup range

If rngValues Is Nothing Then
Set rng = rngLookup
Else
Set rng = rngValues
End If

If rngLookup.Cells.Count <> rng.Cells.Count Then
SearchList = "Range Error!"
Exit Function
End If

'initialise variables
r = rngLookup.Rows.Count
c = rngLookup.Columns.Count
n = r * c
SearchList = ""

For i = 1 To r
For j = 1 To c
'check to make sure the cell has a value to add to the list
If Not IsEmpty(rngLookup.Cells(i, j).Value) And _
InStr(1, UCase(rngLookup.Cells(i, j).Text), UCase(strSearch)) Then
If Len(SearchList) > 0 Then
'add a comma after the existing string for all items after the first
SearchList = SearchList & ", "
End If
SearchList = SearchList & Format(rng.Cells(i, j).Value, "@")
End If
Next j
Next i

End Function 'SearchList

 

[StephenCrump]

You're looping through and testing every cell in rngLookup.

It will be much more efficient to use .Find to locate each occurrence in rngLookup (testing as you loop that you haven't come back to finding the first occurrence for the second time).

 

[pvr928]

Hi PJ

The best way I can see to modify your existing code is to convert rngLookup into an array and then run the loop on the array, rather than the rngLookup itself. This will speed things up significantly.

Have a look here: https://excelmacromastery.com/excel-vba-array/

Cheers

pvr928

 

[pvr928]

StephenCrump's suggestion is better.

For an example of what that is, try Example 3 in .Find and .FindNext In Excel VBA

Good luck!

Cheers

pvr928

 

[peejay]

Thanks Stephen & pvr928 - I'll look into your suggestions.

 

[peejay]

I've managed to get this to work! Yah!

It seems .Find starts at the second cell, then wraps back to the first so if my 1st cell is a match, it gets stuck on the end of my list. Not a big deal at the moment; I'll think about a fix if I get time.

I thought I'd post my Function here in case anyone else is interested.

Thanks again for the tip Stephen & pvr928!

'------------------------------------------------------------------------------
Public Function SearchList(strSearch As String, _
rngLookup As Range, _
Optional rngValues As Range) As String
'This function uses a search value to search a range of cell values for a match,
'and if a match is found a value is appended to a comma separated string.
'
'This function is passed 3 parameters:
' 1) a search string, used to search the value in each cell in a lookup range;
' 2) a cell range of values to lookup; and
' 3) a cell range of the values to store when a match is made to a lookup cell
'If the Lookup and value ranges are the same, the rngValues parameter can be
'omitted.
'Note: the search starts in the 2nd cell, but wraps back to the 1st cell; so
'you will find the matched 1st cell value at the end of the list.
'------------------------------------------------------------------------------

Dim rng As Range 'lookup range

If rngValues Is Nothing Then
Set rng = rngLookup
Else
Set rng = rngValues
End If

If rngLookup.Cells.Count <> rng.Cells.Count Then
SearchList = "Range Error!"
Exit Function
End If

Dim rngCurr As Range 'cell of current match
Dim rngPrev As Range 'cell of previous match
Dim OffsetRow As Long 'offset ROW from Lookup range's Cells(1,1) for match
Dim OffsetCol As Long 'offset COL from Lookup range's Cells(1,1) for match

On Error GoTo Whoa

Set rngCurr = rngLookup.Find( _
What:=strSearch, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

If Not rngCurr Is Nothing Then
Set rngPrev = rngCurr
OffsetRow = rngCurr.Row - rngLookup.Cells(1, 1).Row
OffsetCol = rngCurr.Column - rngLookup.Cells(1, 1).Column

'append the value for the first match
SearchList = Format(rng.Cells(OffsetRow + 1, OffsetCol + 1).Value, "@")
Debug.Print SearchList
Do 'append match values until no more matches found
Set rngCurr = rngLookup.Find( _
What:=strSearch, _
After:=rngCurr, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not rngCurr Is Nothing Then
If rngCurr.Address = rngPrev.Address Then Exit Do
OffsetRow = rngCurr.Row - rngLookup.Cells(1, 1).Row
OffsetCol = rngCurr.Column - rngLookup.Cells(1, 1).Column
SearchList = SearchList & ", " & Format(rng.Cells(OffsetRow + 1, OffsetCol + 1).Value, "@")
Debug.Print SearchList
Else
Exit Do
End If
Loop
Else
SearchList = "Range Error!"
Exit Function
End If

Exit Function

Whoa:
SearchList = "Range Error!"
End Function
'*******************************************************************************

 

[StephenCrump]

I've managed to get this to work! Yah!

Well done! It should be much faster now.

It seems .Find starts at the second cell, then wraps back to the first so if my 1st cell is a match, it gets stuck on the end of my list. Not a big deal at the moment; I'll think about a fix if I get time.

Add this argument to your first .Find: After:=rngLookup.Cells(rngLookup.Count)

You can also get rid of OffsetRow and OffsetCol:

'You can change
OffsetRow = rngCurr.Row - rngLookup.Cells(1, 1).Row
OffsetCol = rngCurr.Column - rngLookup.Cells(1, 1).Column
SearchList = Format(rng.Cells(OffsetRow + 1, OffsetCol + 1).Value, "@")
'To
SearchList = Format(rngCurr.Value, "@")

 

[peejay]

Thanks for the tip Stephen