VBA help to move all images from a cell, not folder?

Hi all, I have a sheet with 8 images in a column F2:F9. Each cell in F2:F9 has one image with corresponding details. I'd like to move all these images to the square box in the 8 card templates I've made on Excel. The square box example can be seen from cell D8:E12.I was referring to this thread on StackOverflow for ideas to move the images into these specific cells but I was unable to pinpoint the specific locations I've designated for the images on these card templates.

May I kindly ask for help from the VBA community on this? Thank you in advance for scratching a huge problem I'm stuck on figuring over the past weekend.

For any extra information, I'm using the latest Microsoft 365 version for Excel.
Attachment 29851

Hi there, just to add, here's an example of the Macro I recorded to achieve this:

Code:

---

Sub Move_images()'
' Move_images Macro
'


'
    ActiveSheet.Shapes.Range(Array("image18.png")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D8").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.63, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.48, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveSheet.Shapes.Range(Array("image25.png")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("L8").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.63, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.47, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveSheet.Shapes.Range(Array("image8.jpg")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("T8").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.645, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.48, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveWindow.SmallScroll Down:=1
    ActiveSheet.Shapes.Range(Array("image21.png")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("AB8").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.64, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.475, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveWindow.SmallScroll Down:=1
    ActiveSheet.Shapes.Range(Array("image22.png")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D30").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=11
    Selection.ShapeRange.ScaleWidth 0.635, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.475, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveWindow.SmallScroll Down:=2
    ActiveSheet.Shapes.Range(Array("image23.png")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("L30").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.6331658291, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.4773869347, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveSheet.Shapes.Range(Array("image16.jpg")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("T30").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.63, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.495, msoFalse, msoScaleFromTopLeft
    Sheets("DATABASE").Select
    ActiveWindow.SmallScroll Down:=1
    ActiveSheet.Shapes.Range(Array("image19.png")).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Range("AB30").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.62, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.485, msoFalse, msoScaleFromTopLeft
    ActiveWindow.SmallScroll Down:=-11
End Sub

---

Hope it helps specify what I'm struggling to understand and build upon.

Perhaps the attached will help?

Quote:

---

Originally Posted by georgiboy

Perhaps the attached will help?

---

Thank you so so much for providing me ideas on how to manually move the items over. I'm also learning how to iterate through items under a column so studying from your VBA code helps so much! Really appreciate you!

manually?????
Name your pictures as the name to the right, put a placeholder (rectangle without lines maybe) where the pictures need to go and a very short macro will do the deed for you.

Based on georgiboy's demonstration, I tried the name manager method and assigned the VBA actions to move the images tied to the name fields. Your suggestion on putting a placeholder helps more because I was navigating cell by cell and scratching my head hard to adjust the image dimensions. Thank you too!

I don't have time at the moment but this is how I fill a rectangle with a picture selected from a folder.

Code:

---

Sub Maybe_Rect1_Only()
Dim fNameAndPath As Variant
Dim img As Picture
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
If fNameAndPath = False Then Exit Sub
    ActiveSheet.Shapes("Rectangle 1").Fill.UserPicture (fNameAndPath)
End Sub

---

I'll have a look tomorrow and see what I can come up with.

Thanks for helping me with your limited time. Your method does look easier to pre-shape images and ngl I am mindblown to learn that you can pre-shape/pre-position mapping things via excel shapes. I'm starting to love vba a bit more as I'm discovering more of it. I'm usually a python programmer, that's why I'm struggling to learn vba, the logic differs quite a bit.

Quote:

---

Originally Posted by jolivanes

I don't have time at the moment but this is how I fill a rectangle with a picture selected from a folder.

Code:

---

Sub Maybe_Rect1_Only()
Dim fNameAndPath As Variant
Dim img As Picture
fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported")
If fNameAndPath = False Then Exit Sub
    ActiveSheet.Shapes("Rectangle 1").Fill.UserPicture (fNameAndPath)
End Sub

---

I'll have a look tomorrow and see what I can come up with.

---

As promised.
The attached is not a replacement for georgiboy's suggestion, just an alternative and as you try it you might see it's shortcomings also.
I do not know if the sometimes errors when working with pictures is excel version related or not but quite a few questions on the web about it.

I have had issues in the past when saving and moving pictures where there is a delay using the clipboard etc...

So where we have:

Code:

---

myPic.Copy
DoEvents
DoEvents

---

The double DoEvents can still cause the errors from time to time with the copy/ paste' so I would lean towards error handling for it as below:

Code:

---

Do
    On Error Resume Next
    myPic.Copy
    If Err.Number = 0 Then Exit Do
    DoEvents
Loop
On Error GoTo 0

---

Code:

---

Do
    On Error Resume Next
    tempChartObj.Chart.Paste
    If Err.Number = 0 Then Exit Do
    DoEvents
Loop
On Error GoTo 0

---

It's not ideal but I have found it to be more reliable than the double DoEvents.

@jolivanes
I see the note about the merged cells - I completely agree however I do use them for instances like this one. I will always avoid them on data or anything for that matter that could be analysed at a later date. When building something that is just to be printed or is just for looks then I will use merging as I suppose this is what I deem it is for. It makes sizing the image in this instance easier to code.


Happy coding people,

George

Nice one George. I'll change it in some of my files where I have the DoEvents implemented. It is no problem for me because I know it happens sometimes and why.
You know that at times someone will come back with a "It doesn't work!"
As far as merged cells is concerned, that is true also of course but it is just that I try to not get into a habit of having to have to choose between "is it going to be a possible problem in the future" or "is it OK now". No biggie though.
Thanks again George and as you said, happy days are ahead we hope.

Avoid merged cells anytime.
See the attachment.

Obviously I do agree with "Avoid merged cells anytime." but if someone insists on it, this would be way around it for this case.
At the beginning and at the end.

Code:

---

Cells(j, i).Resize(6, 2).MergeCells = Cells(j, i).Resize(6, 2).MergeCells = False

---

As you can see there is no justification to use merged cells, not even for visual purposes.
The combination with VBA is nefast.

Quote:

---

Originally Posted by snb

As you can see there is no justification to use merged cells, not even for visual purposes.
The combination with VBA is nefast.

---

I based my example file on the TS's image, if users wish to use them then I have no problem as long as they are not in the data sets. I agree they can be aggravating but they have their purpose.

I am not here to say what people should and should not do - I am here to help them with their issues and offer concise help.

Re: "nefast"
I'm glad I have google.