Option Explicit
Sub Test()
Dim R As Range
'Find all "High" in column C
Set R = FindAll(Range("C:C"), "High")
'Found?
If R Is Nothing Then
'No
Exit Sub
Else
'One column to the left
Set R = R.Offset(, -1)
'Name that cells
R.Name = "HighRange"
End If
End Sub
Function FindAll(ByVal Where As Range, ByVal What, _
Optional ByVal After As Variant, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
Optional ByVal MatchCase As Boolean = False, _
Optional ByVal SearchFormat As Boolean = False) As Range
'Find all occurrences of What in Where (Windows version)
Dim FirstAddress As String
Dim c As Range
'From FastUnion:
Dim Stack As New Collection
Dim Temp() As Range, Item
Dim i As Long, j As Long
If Where Is Nothing Then Exit Function
If SearchDirection = xlNext And IsMissing(After) Then
'Set After to the last cell in Where to return the first cell in Where in front if _
it match What
Set c = Where.Areas(Where.Areas.Count)
'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
'Set After = C.Cells(C.Cells.Count)
Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
End If
Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
If c Is Nothing Then Exit Function
FirstAddress = c.Address
Do
Stack.Add c
If SearchFormat Then
'If you call this function from an UDF and _
you find only the first cell use this instead
Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _
SearchDirection, MatchCase, SearchFormat:=SearchFormat)
Else
If SearchDirection = xlNext Then
Set c = Where.FindNext(c)
Else
Set c = Where.FindPrevious(c)
End If
End If
'Can happen if we have merged cells
If c Is Nothing Then Exit Do
Loop Until FirstAddress = c.Address
'FastUnion algorithm © Andreas Killer, 2011:
'Get all cells as fragments
ReDim Temp(0 To Stack.Count - 1)
i = 0
For Each Item In Stack
Set Temp(i) = Item
i = i + 1
Next
'Combine each fragment with the next one
j = 1
Do
For i = 0 To UBound(Temp) - j Step j * 2
Set Temp(i) = Union(Temp(i), Temp(i + j))
Next
j = j * 2
Loop Until j > UBound(Temp)
'At this point we have all cells in the first fragment
Set FindAll = Temp(0)
End Function