VBA lookup column based on cell contents - excel

Question

I used to have a table with a header row of 10 columns each labelled 1-10. I have combined some of the columns so that now my table looks like this.
0-2
3-4
5
6-7
8-9
10
Red
Orange
Yellow
Green
Blue
Black
Given a score of 5 I can use the following to find column C and get "Yellow":
Set range = Worksheets(colorScore).Range("1:1").Find(What:=Score)
But how can I extend that code to lookup a score of 3? or a score of 1?

Answer 1

Lookup with Intervals
It is assumed that the range contains two rows where the first row contains the lookup value (whole number) or an interval of lookup values (whole numbers) and the second row contains the return values.
Option Explicit
Sub TESTlookupRowInterval()
Dim rg As Range: Set rg = Range("A1").CurrentRegion
Dim Result As Variant
Dim i As Long
For i = -5 To 15
Result = lookupRowInterval(rg, i)
If Not IsEmpty(Result) Then
Debug.Print i, Result
End If
Next i
End Sub
' Result
' 0 Red
' 1 Red
' 2 Red
' 3 Orange
' 4 Orange
' 5 Yellow
' 6 Green
' 7 Green
' 8 Blue
' 9 Blue
' 10 Black
Function lookupRowInterval( _
rg As Range, _
ByVal LookupIndex As Long, _
Optional ByVal Delimiter As String = "-") _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count <> 2 Then Exit Function
Dim Data As Variant: Data = rg.Value
With CreateObject("Scripting.Dictionary")
Dim cInterval() As String
Dim j As Long
Dim n As Long
Dim iStart As Long
Dim iEnd As Long
Dim iTemp As Long
For j = 1 To UBound(Data, 2)
cInterval = Split(Data(1, j), Delimiter)
Select Case UBound(cInterval)
Case 0
If isLng(cInterval(0)) Then
.Item(CLng(cInterval(0))) = Data(2, j)
End If
Case 1
If isLng(cInterval(0)) And isLng(cInterval(1)) Then
iStart = CLng(cInterval(0))
iEnd = CLng(cInterval(1))
If iStart > iEnd Then ' Switch.
iTemp = iStart: iStart = iEnd: iEnd = iTemp
End If
For n = iStart To iEnd
.Item(n) = Data(2, j)
Next n
End If
End Select
Next j
If .Count = 0 Then Exit Function
lookupRowInterval = .Item(LookupIndex)
End With
End Function
Function isLng( _
CheckValue As Variant) _
As Boolean
On Error GoTo clearError
Dim Result As Long
If UBound(Split(CheckValue, ".")) = 0 Then ' Allow only whole numbers.
Result = CLng(CheckValue) ' Error if not number.
isLng = True
End If
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function

Answer 2

Dim numCols As Integer
Dim isRng As String
Dim colHeading As String
Dim lowNum As String
Dim highNum As String
Dim num As String
'Count the number of title row cells
numCols = Worksheets(trait).Range("1:1").End(xlToRight).Column
For i = 1 To numCols
colHeading = Worksheets(trait).Cells(1, i).Value
isRng = InStr(colHeading, "-") 'does it have a dash (is it a range)?
If isRng Then 'if it does have a dash...
lowNum = Mid(colHeading, 1, isRng - 1) 'everything before the dash
highNum = Mid(colHeading, isRng + 1) 'everything after the dash
If score >= lowNum And score <= highNum Then 'if your score is between or equal to the low and high numbers...
Debug.Print "Your score come from column " & i
End If
Else 'if it doesn't have a dash...
num = colHeading
If score = num Then
Debug.Print "Your score come from column " & i
End If
End If
Next i

Answer 3

Function ReturnColor(number As Integer) As String
Set Rng = Application.Intersect(Rows(1), ActiveSheet.UsedRange)
ReturnColor = "#no match#"
For Each cl In Rng
a = Split(cl, "-")
Select Case True
Case number < CInt(a(0))
Exit For
Case number = a(0)
ReturnColor = cl.Offset(1): Exit For
Case UBound(a) = 1
If number <= CInt(a(1)) Then ReturnColor = cl.Offset(1): Exit For
End Select
Next
End Function
Sub test()
Dim i As Integer
For i = -5 To 15
Debug.Print "Color for " & i & " is " & ReturnColor(i)
Next
End Sub