Advise on making UDF more efficient

peejay

Board Regular
Joined
Jul 11, 2003
Messages
79
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
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

StephenCrump

MrExcel MVP
Joined
Sep 18, 2013
Messages
4,043
Office Version
  1. 365
Platform
  1. Windows
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).
 

peejay

Board Regular
Joined
Jul 11, 2003
Messages
79

ADVERTISEMENT

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

peejay

Board Regular
Joined
Jul 11, 2003
Messages
79
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

MrExcel MVP
Joined
Sep 18, 2013
Messages
4,043
Office Version
  1. 365
Platform
  1. Windows
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:

Code:
'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, "@")
 

Watch MrExcel Video

Forum statistics

Threads
1,122,737
Messages
5,597,826
Members
414,180
Latest member
Sir Khaya

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top