Multiple lookup data

[soumen21]

I have a sheet1 like like this

Base Part	Component Number	Component Description	Subclass
ABCD	42G1001-0002	Nut	Tighteners
DCBA	42G1001-0109	Screws	Tighteners

In Sheet2 I have multiple manufacturers for 42G1001-0002, like

UPLOADED CPN	UPLOADED PART	UPLOADED MANUFACTURER
42G1001-0002	CR10-1002-FK	ASJ PTE LTD
42G1001-0002	RK73H1ETTP1002F	KOA SPEER ELECTRONICS INC
42G1001-0002	RK73H1ETTPD1002F	KOA SPEER ELECTRONICS INC

I want to have sheet 1 look like

Base Part	Component Number	Part Number	Manufacturer	Component Description	Subclass
ABCD	42G1001-0002	CR10-1002-FK	ASJ PTE LTD	Nut	Tighteners
ABCD	42G1001-0002	RK73H1ETTP1002F	KOA SPEER ELECTRONICS INC	Nut	Tighteners
ABCD	42G1001-0002	RK73H1ETTPD1002F	KOA SPEER ELECTRONICS INC	Nut	Tighteners
DCBA	42G1001-0109			Screws	Tighteners

Basically, I want to find all the parts numbers and manufacturers under 42G1001-0002 listed in Sheet2 and add in sheet1. The process continues for other parts as well.

Can you help how to do?


Thanks in advance.

 

[mumps]

This seems to work:

Sub InsertData()
    Application.ScreenUpdating = False
    Dim rng As Range, desWS As Worksheet, srcWS As Worksheet
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "temp"
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    For Each rng In desWS.Range("B2", desWS.Range("B" & Rows.Count).End(xlUp))
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 1, rng
            .AutoFilter.Range.Offset(1).Copy Sheets("temp").Cells(Sheets("temp").Rows.Count, "B").End(xlUp).Offset(1)
            If .[subtotal(103,A:A)] - 1 > 0 Then
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "A").End(xlUp).Offset(1).Resize(.[subtotal(103,A:A)] - 1) = rng.Offset(, -1)
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "E").End(xlUp).Offset(1).Resize(.[subtotal(103,A:A)] - 1, 2) = Array(rng.Offset(, 1), rng.Offset(, 2))
            Else
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2) = Array(rng.Offset(, -1), rng)
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "E").End(xlUp).Offset(1).Resize(, 2) = Array(rng.Offset(, 1), rng.Offset(, 2))
            End If
        End With
    Next rng
    srcWS.Range("A1").AutoFilter
    With desWS
        .UsedRange.ClearContents
        .Range("A1").Resize(, 6) = Array("Base Part", "Component Number", "Part Number", "Manufacturer", "Component Description", "Subclass")
        Sheets("temp").Range("A2", Sheets("temp").Range("F" & Rows.Count).End(xlUp)).Copy .Range("A2")
        .Columns.AutoFit
        Application.DisplayAlerts = False
        Sheets("temp").Delete
        Application.DisplayAlerts = True
    End With
    Application.ScreenUpdating = True
End Sub

 

[soumen21]

This seems to work:

Sub InsertData()
    Application.ScreenUpdating = False
    Dim rng As Range, desWS As Worksheet, srcWS As Worksheet
    Sheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "temp"
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    For Each rng In desWS.Range("B2", desWS.Range("B" & Rows.Count).End(xlUp))
        With srcWS
            .Range("A1").CurrentRegion.AutoFilter 1, rng
            .AutoFilter.Range.Offset(1).Copy Sheets("temp").Cells(Sheets("temp").Rows.Count, "B").End(xlUp).Offset(1)
            If .[subtotal(103,A:A)] - 1 > 0 Then
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "A").End(xlUp).Offset(1).Resize(.[subtotal(103,A:A)] - 1) = rng.Offset(, -1)
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "E").End(xlUp).Offset(1).Resize(.[subtotal(103,A:A)] - 1, 2) = Array(rng.Offset(, 1), rng.Offset(, 2))
            Else
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2) = Array(rng.Offset(, -1), rng)
                Sheets("temp").Cells(Sheets("temp").Rows.Count, "E").End(xlUp).Offset(1).Resize(, 2) = Array(rng.Offset(, 1), rng.Offset(, 2))
            End If
        End With
    Next rng
    srcWS.Range("A1").AutoFilter
    With desWS
        .UsedRange.ClearContents
        .Range("A1").Resize(, 6) = Array("Base Part", "Component Number", "Part Number", "Manufacturer", "Component Description", "Subclass")
        Sheets("temp").Range("A2", Sheets("temp").Range("F" & Rows.Count).End(xlUp)).Copy .Range("A2")
        .Columns.AutoFit
        Application.DisplayAlerts = False
        Sheets("temp").Delete
        Application.DisplayAlerts = True
    End With
    Application.ScreenUpdating = True
End Sub

Thank you. It worked

 

[mumps]

You are very welcome.