Create range from find & findnext results [duplicate] - excel

Question

This question already has an answer here:
Can the Excel VBA Range.Find method be used to find multiple values?
(1 answer)
Closed 1 year ago.
I have a find function that search through a column, and there might be more than one result. Which I would like to store in a range (instead of a separate array for example).
This is what I have:
Dim searchRange As Range
Set searchRange = ActiveWorkbook.Sheets(SHEET).Range(SEARCHFOLDERCOLUMN & SEARCHSTARTROW & ":" & SEARCHFOLDERCOLUMN & lastRow)
'search for value
Dim searchResult As Range
Dim firstAddress As String
Set searchResult = searchRange.Find(what:=sSearchFolder, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not searchResult Is Nothing The
firstAddress = searchResult.Address
Do
'search for the next one
Debug.Print searchResult.Address
Set searchResult = searchRange.FindNext(searchResult)
'^^^^^ union instead of this ???
'avoid endless loop, when hitting back the first address
If firstAddress = searchResult.Address Then
'Set searchResult = tempSearchResult
Exit Do
End If
Loop While Not searchResult Is Nothing
End If
Debug.Print "out of loop"
My output:
$M$125
$M$148
$M$161
out of loop
How can I get a range like: "$M$125, $M$148, $M$161" ? Where the columns (or rows?) or 3 instead of 1 like I have now.
Thanks for your help.

Answer 1

Reference a 'FindNext Multi Range'
Option Explicit
Sub DebugPrintCCRGtest()
' Needs 'DebugPrintCCRG', 'RefColumn' and 'RefCriteriaColumnRange'.
DebugPrintCCRG ""
DebugPrintCCRG "Yes"
DebugPrintCCRG "No"
DebugPrintCCRG "2"
' Example Results:
' A4,A8:A9,A17
' A2:A3,A7,A12:A14,A21
' A6,A15:A16,A18:A19
' A5,A10:A11,A20
End Sub
Sub DebugPrintCCRG( _
ByVal Criteria As String)
' Needs 'RefColumn' and 'RefCriteriaColumnRange'.
Dim sFirst As String: sFirst = "A2"
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
Dim crg As Range: Set crg = RefColumn(ws.Range(sFirst))
If crg Is Nothing Then Exit Sub
Dim ccrg As Range: Set ccrg = RefCriteriaColumnRange(crg, Criteria)
If ccrg Is Nothing Then Exit Sub
Debug.Print ccrg.Address(0, 0)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range combined from all the cells
' of a one-column range ('crg'), whose values are equal
' to a string ('Criteria').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCriteriaColumnRange( _
ByVal crg As Range, _
ByVal Criteria As String) _
As Range
If crg Is Nothing Then Exit Function
Dim cCell As Range: Set cCell = crg.Find(Criteria, _
crg.Cells(crg.Cells.Count), xlFormulas, xlWhole)
If cCell Is Nothing Then Exit Function
Dim drg As Range: Set drg = cCell
Dim FirstAddress As String: FirstAddress = cCell.Address
Do
Set drg = Union(drg, cCell)
Set cCell = crg.FindNext(cCell)
Loop Until cCell.Address = FirstAddress
If drg Is Nothing Then Exit Function
Set RefCriteriaColumnRange = drg
End Function