VBA loop to search every cell value from one column in another one and transpose the data from that row

[Jakov]

Hi, Community!
I will really appreciate some help with a VBA code that I'm trying to create for my project. This is 1 step in a macro that i can`t figure out miself. Images attached.
I need to loop search every cell in D column in J column and transpose data from a matching row in D Column.

Ammount of components will always match empty rows. and i need to get the following result:

Alternatevely I had found a code on this forum by @JoeMo that i managed to edit. And it might be easier to transpose the data from the following setup.

Sub FruitSearch()
Dim lR1 As Long, vA As Variant, R1 As Range, n As Long
Dim lR2 As Long, i As Long, R2 As Range
lR1 = Range("C" & Rows.Count).End(xlUp).Row
lR2 = Range("I" & Rows.Count).End(xlUp).Row
Set R1 = Range("A2:C" & lR1)
Set R2 = Range("I2:I" & lR2)
vA = R1.Value
For i = LBound(vA, 1) To UBound(vA, 1)
    If Not IsError(Application.Match(vA(i, 3), R2, 0)) Then
        n = WorksheetFunction.Match(vA(i, 3), R2, 0)
        vA(i, 1) = R2.Cells(n, 1).Offset(0, 1).Value
        vA(i, 2) = R2.Cells(n, 1).Offset(0, -1).Value
    End If
    On Error GoTo 0
Next i
Range("A2:C" & lR1).Value = vA
End Sub

Result i am getting is:

So how can everything be transposed in the way i need?
Thank you for your time

 

[offthelip]

try this code which uses variant arrays and a dictionary so it will be very fast:

Sub test()
  Dim Dic As Object
  Set Dic = CreateObject("Scripting.dictionary")
lastrowd = Cells(Rows.Count, "D").End(xlUp).Row
 inarr = Range(Cells(1, 4), Cells(lastrowd, 4))
 'find largest gap
 Gap = 0
 gapc = 0
 For i = 1 To lastrowd
  If inarr(i, 1) = "" Then
    gapc = gapc + 1
    If gapc > Gap Then Gap = gapc
  Else
    gapc = 0
  End If
 Next i
 outarr = Range(Cells(1, 4), Cells(lastrowd + Gap, 4))
 
 lastrowj = Cells(Rows.Count, "J").End(xlUp).Row
 Datarr = Range(Cells(1, 10), Cells(lastrowd, 10 + Gap))
 For i = 1 To UBound(Datarr)
      Dic(Datarr(i, 1)) = i   ' load all the component data into dictionary
 Next i
For i = 1 To lastrowd
 If inarr(i, 1) <> "" Then
   rowno = Dic(inarr(i, 1))
   For j = 2 To UBound(Datarr, 2)
    If Datarr(rowno, j) = "" Then Exit For
    outarr(i + j - 1, 1) = Datarr(rowno, j)
   Next j
 End If
Next i
 Range(Cells(1, 4), Cells(lastrowd + Gap, 4)) = outarr

 

[Jakov]

offthelip Thank you. I could not create something like that miself. That does exactly what i need and I can understand this code and edit it for some other actions.​

 

[offthelip]

welcome to the forum and glad we could help