VBA code to return multiple lookup values in one comma separated works but crashes if there's an empty cell

user_9548999 0
Viewed 85

I've found this code online which works like vlookup function but returns multiple data in one cell separated by comma and it works most of the time. But when there's a blank cell in the lookup value it causes a crash. It takes a long time to process too. I tried to tinker with it but I'm completely new to VBA coding. I was wondering if anyone could please help me fix the issue and maybe optimize the code a little so it doesn't crash or take as long. Lookup value Table array

Here's the code

    Function MultiVLookUp(LookupValue As String, LookupRange As Range, ColumnNumber As Integer, Char As String)
    Dim I As Long
    Dim xRet As String
    For I = 1 To LookupRange.Columns(1).Cells.Count
        If LookupRange.Cells(I, 1) = LookupValue Then
            If xRet = "" Then
                xRet = LookupRange.Cells(I, ColumnNumber) & Char
            Else
                xRet = xRet & "" & LookupRange.Cells(I, ColumnNumber) & Char
            End If
        End If
    Next
    MultiVLookUp = Left(xRet, Len(xRet) - 1)
End Function

Thanks in advance.

vba excel
2 Answers

Multi VLookUp: Delimited Return (UDF)

  • You'll use it in the same way as before, only I set the last parameter, the parameter of the Char (Delimiter) argument, as optional (default) to your 'favorite' ", " so you don't need to add it anymore.
  • If you were using an array formula, don't do it anymore.
Option Explicit

Function MultiVLookUp( _
    ByVal LookupValue As String, _
    ByVal LookupRange As Range, _
    ByVal ColumnNumber As Long, _
    Optional ByVal Char As String = ", ") _
As String
    
    If Len(LookupValue) = 0 Then Exit Function
    
    Dim lData As Variant
    Dim vData As Variant
    Dim lrCount As Long
    
    With LookupRange
        lrCount = .Rows.Count
        If lrCount = 1 Then
            ReDim lData(1 To 1, 1 To 1): lData(1, 1) = .Columns(1).Value
            ReDim vData(1 To 1, 1 To 1): vData(1, 1) _
                = .Columns(ColumnNumber).Value
        Else
            lData = .Columns(1).Value
            vData = .Columns(ColumnNumber).Value
        End If
    End With
           
    Dim r As Long
    Dim rString As String
    
    For r = 1 To lrCount
        If CStr(lData(r, 1)) = LookupValue Then
            rString = rString & CStr(vData(r, 1)) & Char
        End If
    Next r
    If Len(rString) = 0 Then Exit Function
    
    MultiVLookUp = Left(rString, Len(rString) - Len(Char))

End Function
user_98140690

Im not really sure the point of this macro considering it just outputs the same value repeatedly but here ya go.

Sub main()

    ' ws is the worksheet object referencing "Sheet1"
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
                                
                                      ' Top Left (r, c)          (r, c) Bottom Right
    Dim rng As Range: Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(6, 6))

    Dim lookupValue As String: lookupValue = ""

    Dim outStr As String: outStr = rangeValuesToString(rng, lookupValue)

    Debug.Print outStr

End Sub

Function rangeValuesToString(rng As Range, lookupValue As String) As String

    Dim topRow As Integer: topRow = rng.Row
    Dim botRow As Integer: botRow = rng.Row - 1 + rng.Rows.Count

    Dim leftCol As Integer: leftCol = rng.Column
    Dim rightCol As Integer: rightCol = rng.Column - 1 + rng.Columns.Count

    Dim i  As Integer, j As Integer
    Dim outStr As String: outStr = ""

    ' Iterates through each column moving left to right
    For i = leftCol To rightCol
        For j = topRow To botRow
            If rng.Cells(j, i).Value = lookupValue Then
                outStr = outStr & rng.Cells(j, i).Value & ", "
            End If
        Next j
    Next i

    rangeValuesToString = Left(outStr, Len(outStr) - 2)

End Function
user_148805780
Related