Return Multiple Values horizontally

[amit_gupta123]

Hii all

Please help in getting the multiple values horizontally which matches a criterion. My data base is Column A and B. The search value if in column G and the search returns multiple results which matches in column A. Sample sheet is attached herewith

Appreciate your help

Regards

 

[jindon]

In H2
=IFERROR(INDEX($A$1:$B$9,SMALL(IF($A$1:$A$9=$G2,ROW($A$1:$A$9)),COLUMN(A1)),2),"")
confirm with Ctrl+Shift+Enter(array formula entry)
then copy right + down.

You need to clean the data in A2:A4.

 

[amit_gupta123]

Thanks for the response.. m using the same index and match combi but being an array formula it becomes very slow. I am working on 90000 rows.

So I was looking for the code which could work faster

Regards

 

[jindon]

Then

Sub test()
    Dim a, i As Long, ii As Long, w
    a = Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                .Item(a(i, 1)) = Array(.Count + 2, 2)
                For ii = 1 To 2
                    a(.Item(a(i, 1))(0), ii) = a(i, ii)
                Next
            Else
                w = .Item(a(i, 1))
                w(1) = w(1) + 1
                If w(1) > UBound(a, 2) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                End If
                a(w(0), w(1)) = a(i, 2): .Item(a(i, 1)) = w
            End If
        Next
        i = .Count + 1
    End With
    With [g1].Resize(i, UBound(a, 2))
        .CurrentRegion.ClearContents
        .Value = a
        If .Columns.Count > 2 Then
            With .Cells(1, 2)
                .Value = .Value & 1
                .AutoFill .Resize(, UBound(a, 2) - 1)
            End With
        End If
    End With
End Sub

 

[amit_gupta123]

Sir output looks like the following

Col G
CustID Product1 Product2 Product3
002 xyz abc mmm
003 def hhh
005 fff

 

[jindon]

You only need the values already in col.G?

My result should look like

CustID Product1 Product2 Product3
002 xyz abc mmm
003 def hhh
004 yyy
005 fff
006 kkk

 

[amit_gupta123]

Sir In column G the unique values are getting reflected and in adjacent cells the matches values are appearing. It is working fine. But in Col G it is the search criterion and i want to search for only few cust IDs from the list appearing in Column A.

Regards

 

[jindon]

Change to

Sub test()
    Dim a, b, c, i As Long, ii As Long, t As Long
    a = Cells(1).CurrentRegion.Value
    With [g1].CurrentRegion
        b = .Value: ReDim c(1 To UBound(b, 1))
        t = UBound(b, 2)
        For i = 2 To UBound(b, 1)
            For ii = 2 To UBound(a, 1)
                If b(i, 1) = a(ii, 1) Then
                    c(i) = c(i) + 1
                    If UBound(b, 2) < c(i) + 1 Then
                       ReDim Preserve b(1 To UBound(b, 1), 1 To c(i) + 1)
                    End If
                    b(i, c(i) + 1) = a(ii, 2)
                End If
        Next ii, i
        With .Resize(, UBound(b, 2))
            .Value = b
            If UBound(b, 2) > t Then
                .Cells(1, t).AutoFill .Cells(1, t).Resize(, UBound(b, 2) - t + 1)
            End If
        End With
    End With
End Sub

Or just

Sub test()
    Dim r As Range, x
    For Each r In Range("g2", Range("g" & Rows.Count).End(xlUp))
        x = Filter(Evaluate("transpose(if(a1:a100000=" & r.Address & ",b1:b100000))"), False, 0)
        If UBound(x) > -1 Then r(, 2).Resize(, UBound(x) + 1) = x
    Next
End Sub

 

[Marc L]

Hi !​

The search value if in column G and the search returns multiple results which matches in column A.

Working with exact ID in column A :​

Sub Demo()
    With Sheet1.Cells(7).CurrentRegion.Rows
        With .Item(2).Resize(.Count - 1).Columns
            VR = .Item(1).Value
            .Item(2).Resize(, .Count - 1).ClearContents
        End With
    End With
        VA = Sheet1.Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
            For Each V In VR:  .Item(V) = "":  Next
        For R& = 2 To UBound(VA)
            If .Exists(VA(R, 1)) Then .Item(VA(R, 1)) = .Item(VA(R, 1)) & VA(R, 2) & vbTab
        Next
            VA = Application.Transpose(.Items)
            .RemoveAll
    End With
         Application.DisplayAlerts = False
    With Sheet1.[H2].Resize(UBound(VA))
        .Value = VA
        .TextToColumns Tab:=True
    End With
         Application.DisplayAlerts = True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[Stefan Teuthof]

Change to

Sub test()
    Dim a, b, c, i As Long, ii As Long, t As Long
    a = Cells(1).CurrentRegion.Value
    With [g1].CurrentRegion
        b = .Value: ReDim c(1 To UBound(b, 1))
        t = UBound(b, 2)
        For i = 2 To UBound(b, 1)
            For ii = 2 To UBound(a, 1)
                If b(i, 1) = a(ii, 1) Then
                    c(i) = c(i) + 1
                    If UBound(b, 2) < c(i) + 1 Then
                       ReDim Preserve b(1 To UBound(b, 1), 1 To c(i) + 1)
                    End If
                    b(i, c(i) + 1) = a(ii, 2)
                End If
        Next ii, i
        With .Resize(, UBound(b, 2))
            .Value = b
            If UBound(b, 2) > t Then
                .Cells(1, t).AutoFill .Cells(1, t).Resize(, UBound(b, 2) - t + 1)
            End If
        End With
    End With
End Sub

Or just

Sub test()
    Dim r As Range, x
    For Each r In Range("g2", Range("g" & Rows.Count).End(xlUp))
        x = Filter(Evaluate("transpose(if(a1:a100000=" & r.Address & ",b1:b100000))"), False, 0)
        If UBound(x) > -1 Then r(, 2).Resize(, UBound(x) + 1) = x
    Next
End Sub

Hi,

That smaller VBA code works a treat, awesome!!!

How can I reference the same ranges but from another sheet in the same workbook.

Example in the line below

x = Filter(Evaluate("transpose(if(a1:a100000=" & r.Address & ",b1:b100000))"), False, 0)

Thanks very much in advance

 

[Stefan Teuthof]

Hi,

That smaller VBA code works a treat, awesome!!!

How can I reference the same ranges but from another sheet in the same workbook.

Example in the line below

x = Filter(Evaluate("transpose(if(a1:a100000=" & r.Address & ",b1:b100000))"), False, 0)

Thanks very much in advance

Actually I worked it out, just add the sheet name in front.

x = Filter(Evaluate("transpose(if(Sheet1!a1:a100000=" & r.Address & ",Sheet1!b1:b100000))"), False, 0)