Custom VBA Vlookup-CodePudding

I was hoping to get some help with this custom vlookup I found online. It is designed to look up based on background color but it is written to return only the first result or the last result in a given range.

how can it be written to be more dynamic like a regular vlookup all the values that have the same color?

for example say the color yellow has 5 values 1,2,3,4,5 how can the code be written to return 1,2,3,4,5

VBA code:

Function myvlookup(r1 As Range, r2 As Range, n As Integer, a As Boolean) As Variant

Application.Volatile

Dim cel As Range

Dim i As Integer

i = 0

For Each cel In r2

If cel.Interior.Color = r1.Interior.Color Then

 myvlookup = cel.Offset(0, n - 1).Value
 i = i   1
 If a = False Then
 
Exit For

 End If
 
End If


Next


If i = 0 Then myvlookup = "#N/A"



End Function

CodePudding user response：

Is this what you want?

Sub z()

Dim rng1 As Range
Dim rng2 As Range
Dim num As Integer

Set rng1 = ActiveSheet.Range("A2")
Set rng2 = ActiveSheet.Range("E2:E6")
num = 4

x = myvlookup(rng1, rng2, num, True)

q = 2
For Each E In x
    Cells(q, "E") = E
    q = q   1
Next

End Sub

Function myvlookup(r1 As Range, r2 As Range, n As Integer, a As Boolean) As Variant

Application.Volatile

Dim cel As Range
Dim i As Integer
Dim arr(5) As Variant

i = 0

For Each cel In r2

    If cel.Interior.Color = r1.Interior.Color Then
    
     arr(i) = cel.Offset(0, n - 7).Value 'offset to column B
     i = i   1
     
     If a = False Then
        Exit For
     End If
     
    End If

Next

If i = 0 Then myvlookup = "#N/A"

myvlookup = arr()

End Function

CodePudding user response：

This will take either a single or multi-cell range and return the offset or the N/A error value based on color match of the calling cell.

    Dim cellcount As Long
    cellcount = rng.Cells.Count
    If cellcount > 1 Then
        Dim cell As Range
        Dim returnarr
        ReDim returnarr(1 To cellcount, 1 To 1)
        Dim i As Long
        i = 1
        For Each cell In rng
            If Application.Caller.Interior.Color = cell.Interior.Color Then
                returnarr(i, 1) = cell.Offset(, 1).Value
            Else
                returnarr(i, 1) = CVErr(xlErrNA)
            End If
            i = i   1
        Next cell
        test2 = returnarr
    ElseIf Application.Caller.Interior.Color = rng.Interior.Color Then
        test2 = rng.Offset(, 1).Value
    Else
        test2 = CVErr(xlErrNA)
    End If

The Multi-cell aspect will only work if your Excel version supports spill formulas.