Help with VLookups/VBA To Loop through Rows and find/create Unique Rows

[phonesdontfly]

Hello,


I have a sheet ("Product") that has unique identifiers (PROD_ID) for each product in my database.
And I have another sheet, called "Images", that has all the images associated with each product. Many products have multiple images, and thus have multiple rows with the same Prod_IDs in my "Images" Sheet.

I need to find a way to pull in the image URL (or multiple URLs) associated with each Product and then place them into my "Product" Sheet.
When there are multiple images for a product, they need to go on a blank row underneath the primary image row (as shown in the [Desired] Sheet 1 example below).


[Current] Sheet 1 (Products)

PROD_ID	Product Name	Image URL
123	widget1
456	widget2

<tbody>
</tbody>

Sheet 2 (Images)

Prod_ID	IMAGE_URL
123	image1a.jpg
456	image9.jpg
123	image1b.jpg

<tbody>
</tbody>

[Desired] Sheet 1 (Products)

PROD_ID	Product Name	Image URL
123	widget1	image1a.jpg
	widget1	image1b.jpg
	widget1	image1c.jpg
456	widget2	image9.jpg

<tbody>
</tbody>

---

My first/only thought was to use a VLOOKUP to find the Prod ID and then pull the corresponding Image URL, however that only works for the first match, and unfortunately I have multiple matching results here.

I'm also not sure how to automatically create a blank row when adding the multiple images for a product.

I'm guessing there's some way with VBA to loop through and automate this (as there's several thousand rows of data), but I'm not totally sure where to start. Does anyone know of a way to do this?

Thanks!

 

[Eric W]

Something like this might work for you.

Open a COPY of your workbook. Press Alt-F11 to open the VBA editor. From the menu, select Insert > Module. Paste the following code into the window that opens:

Sub DoImages()
Dim pr As Worksheet, im As Worksheet, MyDict As Object, r As Long, id As String
Dim i As Long, images As Variant


    Application.ScreenUpdating = False
    Set pr = Sheets("Products")
    Set im = Sheets("Images")
    
    Set MyDict = CreateObject("Scripting.Dictionary")
    For r = 2 To pr.Cells(Rows.Count, "A").End(xlUp).Row
        id = pr.Cells(r, "A")
        MyDict(id) = ""
    Next r
        
    For r = 2 To im.Cells(Rows.Count, "A").End(xlUp).Row
        id = im.Cells(r, "A")
        MyDict(id) = MyDict(id) & "," & im.Cells(r, "B")
    Next r
    
    For r = pr.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        id = pr.Cells(r, "A")
        images = Split(Mid(MyDict(id), 2), ",")
        For i = 0 To UBound(images)
            If i = 0 Then
                pr.Cells(r, "C") = images(i)
            Else
                pr.Rows(r + 1).Insert
                pr.Cells(r + 1, "C") = images(i)
            End If
        Next i
    Next r
    Application.ScreenUpdating = True
    
End Sub

Take note of the items in red, these are either sheet names, or columns. Close the VBA editor with Alt-Q, or the X in the top right. Back in Excel, press Alt-F8 to open the macro selector. Select DoImages and click Run.

Note that there is very little error handling in this code! It assumes your Products start on row 2, and have no blank lines between them. The images also start on row 2, and have no blank lines. So you can only run this once, because the first time will add blank lines in column A.

Let me know if this works for you.

 

[phonesdontfly]

Thanks Eric! This worked flawlessly!

 

[Eric W]

You're welcome!