I have a Master sheet with all the details of the products, including its images. Currently, if I want to send a quotation or stock report to a customer according to their product requirements, here's how it goes -
I want to automate this process. I screen-recorded a short video of how I want it to work. Please check. Link to video
As you can see, after I enter a product SKU in the second sheet, all the details gets filled automatically using vlookup, but for the images, I manually copy pasted it. So, I am looking for a VBA code, that automatically grabs the image from the Master sheet, corresponding to the product SKU and paste it in the cell, exactly like the vlookup, but for images. And also work for all the rows where the SKU is entered (just like how in vlookup, I just drag the formula down and it shows #N/A when there is no data in the first column, but once the data is there, it automatically fills the data from the Master sheet. I want the same thing for images).
So now, if I get a list of product's SKUs from a customer, I just have to enter it in the first column, and all the other details will be automatically filled including the images. This could save a lot of time for a large list of products.
I have also shown in the video that the image's name in the Master sheet is corresponding to the product SKU.
I hope I am illustrating my point correctly, and I apologize if my English is hard to understand.
Please, use the next code. You should adapt strSKU for your real product code. But that product code MUST exist in B:B of the sheet where the picture should be copied:
Sub copyPicturesFromMaster()
Dim wsM As Worksheet, wsOf As Worksheet, sh As Shape, shP As Shape, strSKU As String, rngSKU As Range
strSKU = "123ABC" 'use here your SKU code
Set wsM = ActiveSheet 'use here your master sheet (maybe Worksheets("Master")
Set wsOf = wsM.Next 'use here the sheet where you need to paste the copied picture
For Each sh In wsM.Shapes 'iterate between master sheet shapes:
If TypeName(sh.OLEFormat.Object) = "Picture" And sh.name = strSKU Then 'if its name is the searched SKU and is a Picture
'find the cell where the SKU product code exists (in B:B):
Set rngSKU = wsOf.Range("B:B").Find(What:=strSKU, After:=wsOf.Range("B2"), LookIn:=xlValues, LookAt:=xlWhole)
If Not rngSKU Is Nothing Then 'if it has been found:
sh.Copy: wsOf.Paste 'copy - paste the necessary shape
Set shP = wsOf.Shapes(wsOf.Shapes.count) 'set the last copied sheet
shP.left = rngSKU.Offset(, 1).left 'move it in the right place
shP.top = rngSKU.Offset(, 1).top
Else
MsgBox "Product """ & strSKU & """ could not be found in B:B column..." 'if no SKU code in columln B:B
End If
Exit For
End If
Next sh
Debug.Print TypeName(Selection)
End Sub
Edit:
The next version event code does not need any Vlookup formulas. Anyhow, it is better to copy the sheet without formulas targeting a non existing workbook:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsM As Worksheet, wsOf As Worksheet, sh As Shape, shp As Shape, strSKU As String
Dim sHeight As Double, sWidth As Double, rngProduct As Range, i As Long
If Target.Value = "" Then Exit Sub
If Target.column = 1 Then
If Target.cells.count > 1 Then MsgBox "This code works only for a single cell (in column A:A) modification)!": Exit Sub
Set wsM = Worksheets("Sheet1") 'use here your master sheet
Set wsOf = Me 'the active sheet (this one)
'find the product code introduced in the offer sheet:
Set rngProduct = wsM.Range("A:A").Find(What:=Target.Value, After:=wsM.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole)
If rngProduct Is Nothing Then MsgBox "No product """ & Target.Value & """ found in the master sheet": Exit Sub
'Copy the fields brought until now using Vlookup:
Application.EnableEvents = False
For i = 2 To 4 'it copies the next three columns after B:B. If more columns necessary to be copied, increas from 4 to necessary
Target.Offset(, i).Value = rngProduct.Offset(, i).Value
Next i
Application.EnableEvents = True
'format C:C column as text (even aleready having numbers formatted as scientifique:
Me.UsedRange.Columns(3).EntireColumn.TextToColumns FieldInfo:=Array(1, 2)
For Each sh In wsM.Shapes 'iterate between master sheet shapes:
If TypeName(sh.OLEFormat.Object) = "Picture" And sh.name = Target.Value Then 'if its name is the searched SKU and is a Picture
sh.Copy: 'copy the necessary shape
Application.Wait Now + TimeValue("00:00:01")
wsOf.Paste
Set shp = wsOf.Shapes(wsOf.Shapes.count) 'set the last copied/created shape
sHeight = shp.height: sWidth = shp.width 'extract initial height and width
'determine which dimension should be diminished, to be sure that both of them are inside the cell:
If shp.height < Target.Offset(, 1).height And shp.width < Target.Offset(, 1).width Then
If shp.height > shp.width Then
shp.height = Target.Offset(, 1).height - 2
If shp.width > Target.Offset(, 1).width Then shp.width = Target.Offset(, 1).width
sWidth = shp.width: sHeight = shp.height
Else
shp.width = Target.Offset(, 1).width - 2
If shp.height > Target.Offset(, 1).height Then shp.height = Target.Offset(, 1).height
sWidth = shp.width: sHeight = shp.height
End If
ElseIf shp.height < Target.Offset(, 1).height And shp.width > Target.Offset(, 1).width Then
shp.width = Target.Offset(, 1).width - 2: sWidth = shp.width: sHeight = shp.height:: sWidth = shp.width
ElseIf shp.height > Target.Offset(, 1).height And shp.width > Target.Offset(, 1).width Then
If shp.height > shp.width Then
shp.height = Target.Offset(, 1).height - 2
If shp.width > Target.Offset(, 1).width Then shp.width = Target.Offset(, 1).width
sWidth = shp.width: sHeight = shp.height
Else
shp.width = Target.Offset(, 1).width - 2:
If shp.height > Target.Offset(, 1).height Then shp.height = Target.Offset(, 1).height
sWidth = shp.width: sHeight = shp.height
End If
End If
'set the correct top and left, to be centered on cell:
shp.top = Target.Offset(, 1).top + (Target.Offset(, 1).height - sHeight) / 2
shp.left = Target.Offset(, 1).left + Target.Offset(, 1) + (Target.Offset(, 1).width - sWidth) / 2
Exit For
End If
Next sh
End If
End Sub
Please, send some feedback after testing them.