Function VLookups(lookupValue, lookupArray, ColumnNumber)
'This function acts somewhat like the built-in VLookup
'Function with exact matches, except that it returns an
'array of all the values corresponding to multiple
'occurrences of the sought value in the left hand column
'(i.e., the first column vector in the lookup array). The
'function is not presently case sensitive.
Dim arr, outputArrayVLookups, tempArrayVLookups, col1 As Variant
Dim p As Long, i As Long, m As Long, j As Integer
Dim present As Boolean
present = False
'Assign to a variable the left hand column
col1 = Application.Index(lookupArray, 0, 1)
'Assign to a variable the number of ocurrences
'of the lookup value
p = ArrayCountIf(col1, lookupValue)
If TypeOf Application.Caller Is Range Then
If p = 0 Then
VLookups = CVErr(xlValue)
Exit Function
End If
Else
If p = 0 Then
VLookups = [#Value!]
Exit Function
End If
End If
'resize the array of index values to accommodate
'the number of occurrences of the lookup value
ReDim tempArrayVLookups(1 To p, 1 To 2)
'Loop to load the array of indexes of lookup
'values; each instance of a lookup value is
'changed so that the Match Function will not
'find it a second time.
For m = 1 To p
i = Application.Match(lookupValue, col1, 0)
If Application.Proper(col1(i, 1)) = Application.Proper(lookupValue) Then
tempArrayVLookups(m, 1) = i
tempArrayVLookups(m, 2) = 1
col1(i, 1) = "yyzz"
Else
m = m - 1
col1(i, 1) = "yyzz"
End If
Next
If IsArray(ColumnNumber) Then
NumCols = UBound(ColumnNumber) - LBound(ColumnNumber) + 1
ColNumArray = True
End If
If TypeName(lookupArray) = "Range" Then
If lookupArray.Areas.Count > 1 Then VLookups = "A range input must be a single-area range": Exit Function
End If
If TypeOf Application.Caller Is Range Then
iRows = Range(Application.Caller.Address).Rows.Count
iCols = Range(Application.Caller.Address).Columns.Count
If ColNumArray Then
If InStr(1, Application.Caller.FormulaArray, "vlookups") = 2 Then
If iCols < NumCols Or iRows < p Then
VLookups = "Select at least " & p & " row(s) and " & NumCols & " column(s)."
Exit Function
End If
End If
ElseIf iRows < p Then
If InStr(1, Application.Caller.FormulaArray, "vlookups") = 2 Then
VLookups = "Select at least " & p & " row(s)."
Exit Function
End If
End If
'Loop to load the array of values corresponding to the
'multiple occurrences of lookup value, i.e., the output
'array. Provision is made for returning multiple values
'corresponding to a single occurrence of lookupValue;
'i.e., for calling this function with, e.g.,
'=VLookups(lookupValue, lookupArray, {2,4,5})
If Not ColNumArray Then
ReDim outputArrayVLookups(1 To Application.Max(iRows, p), 1 To iCols)
For i = 1 To Application.Max(iRows, p)
For j = 1 To iCols
If i > p Or j > 1 Then
outputArrayVLookups(i, j) = ""
Else
outputArrayVLookups(i, j) = lookupArray(tempArrayVLookups(i, j), ColumnNumber)
End If
Next
Next
Else
ReDim outputArrayVLookups(1 To Application.Max(iRows, p), 1 To iCols)
For i = 1 To iRows
For j = 1 To iCols
If j > NumCols Or i > p Then
outputArrayVLookups(i, j) = ""
Else
outputArrayVLookups(i, j) = lookupArray(tempArrayVLookups(i, 1), ColumnNumber(j))
End If
Next
Next
End If
Else
'Loop to load the array of values corresponding to the
'multiple occurrences of lookup value, i.e., the output
'array. Provision is made for returning multiple values
'corresponding to a single occurrence of lookupValue;
'i.e., for calling this function with, e.g.,
'=VLookups(lookupValue, lookupArray, {2,4,5})
If Not ColNumArray Then
ReDim outputArrayVLookups(1 To p, 1 To 1)
For i = 1 To p
For j = 1 To 1
outputArrayVLookups(i, j) = lookupArray(tempArrayVLookups(i, j), ColumnNumber)
Next
Next
Else
ReDim outputArrayVLookups(1 To p, LBound(ColumnNumber) To UBound(ColumnNumber))
For i = 1 To p
For j = LBound(ColumnNumber) To UBound(ColumnNumber)
outputArrayVLookups(i, j) = lookupArray(tempArrayVLookups(i, 1), ColumnNumber(j))
Next
Next
End If
End If
VLookups = outputArrayVLookups
End Function
