Return MULTIPLE corresponding values for one Lookup Value at a time and different ranges - excel

Question

I'm new in this forum and in vba language so i'm hoping for some guidance. I have a workbook with different sheets but right now there are only 3 that matter. The first and thrid sheet have data that will be interconnected in the Sheet2.
In Sheet1 and Sheet3 I have Sheet1_Sheet3_Test. And this is Sheet 2 Sheet2_Test which is, in a first fase all empty and I want to automatize it since i was doing this work manually before. In the image is what I need to get. So far I have the following code, which works and fills column C of Sheet2.
But i'm having problems with Column A. I was trying to simply use a formula like:
{=IF(A3=A2;INDEX(Sheet3!$A$3:$A$16;SMALL(IF(ISNUMBER(SEARCH(Sheet1!$B$3;Sheet3!$C$3:$C$16));MATCH(ROW(Sheet3!$C$3:$C$16);ROW(Sheet3!$C$3:$C$16)));ROW(A1)));INDEX(Sheet3!$A3:$A$16;SMALL(IF(ISNUMBER(SEARCH(Sheet1!$B3;Sheet3!$C$3:$C$16));MATCH(ROW(Sheet3!$C$3:$C$16);ROW(Sheet3!$C$3:$C$16)));ROW(A$1))))}
The problem is I get an error when the text in column C changes and right now I'm stuck. I don't know if it will be better to develop another macro or if there is something I can change in the formula.
I'm sorry if it is difficult to understand what I'm asking but it is kind of hard to explain it.
I need to go throught every row in sheet1, so for example: in Sheet 1 I have in row 3, INST - I_1 and ID - AA. The formula searches for AA on sheet3 and returns all values in order and fills column A in sheet 2. Then it will go to row 4 in sheet 1 again and repeat the process once again until there are no more values on Sheet1.
Sub TestSheet2()
Dim Rng As Range
Dim InputRng As Range, OutRng As Range
xTitleId = "Sheet1"
Sheets("Sheet1").Select
Set InputRng = Application.Selection
On Error Resume Next
Set InputRng = Application.InputBox("Select:", xTitleId, InputRng.Address, Type:=8)
xTitleId = "Sheet2"
Sheets("Sheet2").Select
Set OutRng = Application.InputBox("Select:", xTitleId, Type:=8)
Set OutRng = OutRng.Range("A1")
For Each Rng In InputRng.Rows
xValue = Rng.Range("A1").Value
xNum = Rng.Range("C1").Value
OutRng.Resize(xNum, 1).Value = xValue
Set OutRng = OutRng.Offset(xNum, 0)
Next
End Sub

Answer 1

Based on the images provided, I was able to loop through a couple of arrays and come up with this.
Sub fill_er_up()
Dim a As Long, b As Long, c As Long
Dim arr1 As Variant, arr2() As Variant, arr3 As Variant
With Worksheets("sheet1")
With .Range(.Cells(3, 1), .Cells(Rows.Count, 2).End(xlUp))
.Cells.Sort key1:=.Columns(2), order1:=xlAscending, _
key2:=.Columns(1), order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
arr1 = .Cells.Value2
End With
End With
With Worksheets("sheet3")
With .Range(.Cells(3, 1), .Cells(Rows.Count, 3).End(xlUp))
.Cells.Sort key1:=.Columns(3), order1:=xlAscending, _
key2:=.Columns(1), order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlNo
arr3 = .Cells.Value2
End With
End With
For a = LBound(arr1, 1) To UBound(arr1, 1)
For c = LBound(arr3, 1) To UBound(arr3, 1)
'Do While arr3(c, 3) <> arr1(a, 2): c = c + 1: Loop
If arr3(c, 3) = arr1(a, 2) Then
b = b + 1
ReDim Preserve arr2(1 To 3, 1 To b)
arr2(1, b) = arr3(c, 1)
arr2(2, b) = arr3(c, 3)
arr2(3, b) = arr1(a, 1)
End If
Next c
Next a
With Worksheets("sheet2")
Dim arr4 As Variant
arr4 = my_2D_Transpose(arr4, arr2)
.Cells(3, 1).Resize(UBound(arr4, 1), UBound(arr4, 2)) = arr4
End With
Erase arr1: Erase arr2: Erase arr3: Erase arr4
End Sub
Function my_2D_Transpose(a1 As Variant, a2 As Variant)
Dim a As Long, b As Long
ReDim a1(1 To UBound(a2, 2), 1 To UBound(a2, 1))
For a = LBound(a2, 1) To UBound(a2, 1)
For b = LBound(a2, 2) To UBound(a2, 2)
a1(b, a) = Trim(a2(a, b))
Next b
Next a
my_2D_Transpose = a1
End Function
I added in the id to the second column of the results in sheet2. It seemed a reasonable way to fill blank cells.
      

Answer 2

I was able to recreate your results table with the code below, filtering the range on Sheet3.
Option Explicit
Sub MergeIDs()
Dim instSh As Worksheet
Dim compfSh As Worksheet
Dim mergeSh As Worksheet
Dim inst As Range
Dim compf As Range
Dim merge As Range
Dim lastInst As Long
Dim lastCompf As Long
Dim allCompf As Long
Dim i As Long, j As Long
Dim mergeRow As Long
'--- initialize ranges
Set instSh = ThisWorkbook.Sheets("Sheet1")
Set compfSh = ThisWorkbook.Sheets("Sheet3")
Set mergeSh = ThisWorkbook.Sheets("Sheet2")
Set inst = instSh.Range("A3")
Set compf = compfSh.Range("A2")
Set merge = mergeSh.Range("A3")
lastInst = instSh.Cells(instSh.Rows.Count, "A").End(xlUp).Row
allCompf = compfSh.Cells(compfSh.Rows.Count, "A").End(xlUp).Row
'--- clear destination
mergeSh.Range("A:C").ClearContents
merge.Cells(0, 1).Value = "COMPF"
merge.Cells(0, 3).Value = "INST"
'--- loop and build...
mergeRow = 1
For i = 1 To (lastInst - inst.Row + 1)
'--- set the compf range to autofilter
compfSh.AutoFilterMode = False
compf.Resize(allCompf - compf.Row, 3).AutoFilter
compf.Resize(allCompf - compf.Row, 3).AutoFilter Field:=3, Criteria1:=inst.Cells(i, 2).Value
'--- merge the filtered values with the inst value
lastCompf = compfSh.Cells(compfSh.Rows.Count, "A").End(xlUp).Row
For j = 1 To (lastCompf - compf.Row)
merge.Cells(mergeRow, 1).Value = compf.Cells(j + 1, 1).Value
merge.Cells(mergeRow, 3).Value = inst.Cells(i, 1).Value
mergeRow = mergeRow + 1
Next j
Next i
End Sub