Search code examples
vbaexceludf

UDF: For cell values less than x in a column, return all values from first column

For a data set like the following, I'd like to, if the value in Row 1 equals a specified value, return all ID column values in rows where the cell value in the specified column is less than 3. (No values repeat in the ID column or in Row 1 "headers".)

ID  | X | Y | Z    
123 | 1 | 2 | 5    
456 | 2 | 6 | 4    
789 | 6 | 1 | 2

e.g., if a column header = "X", return value of "123, 456". If Y, "123, 789". If Z, "789". I've found a variation of a "multicat formula" (in the edit to the linked answer) that comes close to addressing my needs, but I'm having trouble adapting it. 

  Public Function MultiCat2( _
    ByRef rRng As Excel.Range, _
    Optional ByVal sDelim As String = "") _
         As String
 Dim rCell As Range
 For Each rCell In rRng
    If rCell.Value < 3 Then
     MultiCat2 = MultiCat2 & sDelim & rCell.Text
     End If
 Next rCell
 MultiCat2 = Mid(MultiCat2, Len(sDelim) + 1)  
 End Function

If I run the function as is on X, for example, it returns a value of "1, 2." The result needs to always be from the ID column, regardless of the column being evaluated. That part should be simple, but I can't figure out how to do it without Offset, which doesn't help me, because the evaluated column will be variable.

I have the plain English logic I need: "If value of cell in a1:d1 = X, MultiCat a1:a4 where cell value in [selected column] is <3." I can find the column I'd like to perform the evaluation on using the Match function, and I have the code I think I need to concatenate results in a single cell.

I just can't figure out how to incorporate the result of the Match into the function, or how to get the function to concatenate the ID column.

Solution

  • You could a) hard-code the ID column into the function; b) add a parameter to pass the ID column into the function; c) pass the column header name into the function.

    Option Explicit

Public Function MultiCat2A(ByRef rRng As Excel.Range, _
                           Optional ByVal sDelim As String = ",") _
                         As String
    Dim c As Long, cRng As Range

    'restrict rRng to the .UsedRange
    Set rRng = Intersect(rRng, rRng.Parent.UsedRange)
    'set cRng to another column but equal to rRng
    Set cRng = Intersect(rRng.EntireRow, rRng.Parent.Columns("A"))

    For c = 1 To rRng.Count
       If rRng(c).Value < 3 Then
        MultiCat2A = MultiCat2A & sDelim & cRng(c).Text
        End If
    Next c

    MultiCat2A = Mid(MultiCat2A, Len(sDelim) + 1)
    If CBool(Len(sDelim)) Then
        Do While Right(MultiCat2A, Len(sDelim)) = sDelim
            MultiCat2A = Left(MultiCat2A, Len(MultiCat2A) - Len(sDelim))
        Loop
    End If
End Function

Public Function MultiCat2B(ByRef cRng As Range, _
                           ByRef rRng As Excel.Range, _
                           Optional ByVal sDelim As String = ",") _
                         As String
    Dim c As Long

    'restrict rRng to the .UsedRange
    Set rRng = Intersect(rRng, rRng.Parent.UsedRange)
    'resize cRng to the same as rRng
    Set cRng = cRng(1, 1).Resize(rRng.Rows.Count, rRng.Columns.Count)

    For c = 1 To rRng.Count
       If rRng(c).Value < 3 Then
        MultiCat2B = MultiCat2B & sDelim & cRng(c).Text
        End If
    Next c

    MultiCat2B = Mid(MultiCat2B, Len(sDelim) + 1)
    If CBool(Len(sDelim)) Then
        Do While Right(MultiCat2B, Len(sDelim)) = sDelim
            MultiCat2B = Left(MultiCat2B, Len(MultiCat2B) - Len(sDelim))
        Loop
    End If
End Function

Public Function MultiCat2C(ByVal sHdr As String, _
                           ByRef rRng As Excel.Range, _
                           Optional ByVal sDelim As String = ",") _
                         As String
    Dim c As Long, cRng As Range

    'restrict rRng to the .UsedRange
    Set rRng = Intersect(rRng, rRng.Parent.UsedRange)
    'find the column by header label
    c = Application.Match(sHdr, rRng.Parent.Rows(1), 0)
    'offset cRng by its column vs rRng's column
    Set cRng = rRng(1, 1).Offset(0, c - rRng.Column)

    For c = 1 To rRng.Count
       If rRng(c).Value < 3 Then
        MultiCat2C = MultiCat2C & sDelim & cRng(c).Text
        End If
    Next c

    MultiCat2C = Mid(MultiCat2C, Len(sDelim) + 1)
    If CBool(Len(sDelim)) Then
        Do While Right(MultiCat2C, Len(sDelim)) = sDelim
            MultiCat2C = Left(MultiCat2C, Len(MultiCat2C) - Len(sDelim))
        Loop
    End If
End Function

    In sample image's G2:G5 as,

    =MultiCat2A(B2:B4)
=MultiCat2B($A2:$A4, B2:B4)
=MultiCat2C("ID", B2:B4)
=MultiCat2C($A1, B2:B99)

    Fill right as necessary.

    concat_again