# Return Multiple Values horizontally

#### amit_gupta123

##### Member
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

Regards

#### Attachments

• 13.7 KB Views: 40

#### jindon

##### Well-Known Member
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

##### Member
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

##### Well-Known Member
Then
Code:
``````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

##### Member
Sir output looks like the following

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

#### jindon

##### Well-Known Member
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

##### Member
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

##### Well-Known Member
Change to
Code:
``````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
Code:
``````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``````

Last edited:
• Stefan Teuthof

#### Marc L

##### Excel Ninja
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 :​
Code:
``````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
With Sheet1.[H2].Resize(UBound(VA))
.Value = VA
.TextToColumns Tab:=True
End With
End Sub``````
Do you like it ? So thanks to click on bottom right Like !

#### Stefan Teuthof

##### New Member
Change to
Code:
``````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
Code:
``````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)

#### Stefan Teuthof

##### New Member
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)