- last edited on
I am new to VBA and macros and I was hoping that someone could help me writing the VBA to insert a photo from your personal files. I created the button, but I just need to write the VBA to pull up the users files so they can select the photo. From there I want the photo to be placed in the cell (you'll see on the sheet which cell I am referring to). The cells are already merged together. I want the photo to fit in the cell that is already merged.
For some reason this forum won't let me upload a macro, so I am going to insert the excel file. You'll see where I want the photo's on the "FLYER V1" tab.
Thanks! Let me know if you have any questions
05-01-2018 11:00 AM - edited 05-01-2018 11:01 AM
Please follow the below steps to accomplish your task:
1. Open the Visual Basic Editor (VBE) using Alt + F11
2. Insert > Module
3. Paste the below code in the new code module
Sub GetPic() Dim fNameAndPath As Variant Dim img As Picture fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported") If fNameAndPath = False Then Exit Sub Set img = ActiveSheet.Pictures.Insert(fNameAndPath) With img 'Resize Picture to fit in the range.... .Left = ActiveSheet.Range("D9").Left .Top = ActiveSheet.Range("D9").Top .Width = ActiveSheet.Range("D9:H9").Width .Height = ActiveSheet.Range("D9:D28").Height .Placement = 1 .PrintObject = True End With End Sub
4. Go back to the worksheet
5. Right Click on the button > Assign Macro
6. Select the GetPic Macro
After following these steps you should get the expected result.
05-03-2018 04:47 PM
Just wanted to follow up and see if you were able to resolve your issue. If you're still having trouble don't hesitate to reach back out and ask additional inquiries. Always happy to help!
03-20-2019 01:54 PM
That code worked perfectly, my question is I have 6 other locations to place the same image how can I do so for the other 6?
03-20-2019 02:28 PM
Can you please tell me a few things for clarification?
What are the 6 different ranges? If the ranges are on different worksheets can you further clarify with worksheet names?
03-21-2019 06:33 AM
@Matt Mickle the locations for the 6 other images are as follows:
and all on same worksheet.
.Left = ActiveSheet.Range("q3").Left
.Top = ActiveSheet.Range("q3").Top
.Width = ActiveSheet.Range("q4:q8").Width
.Height = ActiveSheet.Range("r4:r8").Height .Placement = 1
.Left = ActiveSheet.Range("q33").Left
.Top = ActiveSheet.Range("q33").Top
.Width = ActiveSheet.Range("q33:q38").Width
.Height = ActiveSheet.Range("r33:r38").Height
.Left = ActiveSheet.Range("q63").Left
.Top = ActiveSheet.Range("q63").Top
.Width = ActiveSheet.Range("q63:q68").Width
.Height = ActiveSheet.Range("r68:r68").Height
They are all about 30 cell spaces lower and I have 7 total. In additional I have a sheet labeled Title Page and there 1 image there with the follow location.
.Left = ActiveSheet.Range("B3").Left
.Top = ActiveSheet.Range("B3").Top
.Width = ActiveSheet.Range("B3:b9").Width
.Height = ActiveSheet.Range("e9:e9").Height
Thank you for your help!
03-21-2019 07:22 AM
Try the below code example which loops through multiple locations on the worksheet. I have commented the code for better understanding.
You may want to note that when you set the width to a value like B3:B9 that is will simple make the image the length of the B column or similarly for E9:E9 it will make the height of the image the height of cell E9.
Sub GetPic() Dim fNameAndPath As Variant Dim img As Picture Dim intLp As Integer Dim arrLeftandTop As Variant Dim arrWidth As Variant Dim arrHeight As Variant fNameAndPath = Application.GetOpenFilename(Title:="Select Picture To Be Imported") 'Open FIle Dialog to allow user to pick picture If fNameAndPath = False Then Exit Sub 'If the user cancels then exit the procedure.... 'Define the different range arrays arrLeftandTop = Array("B3", "Q3", "Q33", "Q63") 'Left and top range values arrWidth = Array("B3:B9", "Q4:Q8", "Q33:Q38", "Q63:Q68") 'Width range values arrHeight = Array("E9:E9", "R4:R8", "R33:R38", "R68:R68") 'Height range values 'Loop through ranges and place pictures one at a time.... 'Note arrays start at 0 ' arrLeftandTop(0) = "B3" ' arrLeftandTop(1) = "Q3" '.....etc For intLp = 0 To 3 Set img = ActiveSheet.Pictures.Insert(fNameAndPath) 'Set image for insert With img 'Resize Picture to fit in the range.... .Left = ActiveSheet.Range(arrLeftandTop(intLp)).Left .Top = ActiveSheet.Range(arrLeftandTop(intLp)).Top .Width = ActiveSheet.Range(arrWidth(intLp)).Width .Height = ActiveSheet.Range(arrHeight(intLp)).Height .Placement = 1 .PrintObject = True End With Next intLp 'Go to next array value... i.e. first loop is 0, next loop is 1....etc. End Sub
10-13-2019 05:35 PM
Hello Matt Mickle
Can you help me on this Macro Please. I want to insert Picture but this Macro is not working in my MacBook maybe this Macro for PC computer.
11-26-2019 12:47 PM
Hey @Matt Mickle
I'm having problems with this Macro for inserting photos. I copied it from a PC parallel to use on my Mac but it's keeps telling me the file doesn't exist. Can you help?
I uploaded a test file, the other one is a much larger file.
Sub InsertAnyPicture() Dim image As String Columns("A:B").Select Selection.Insert Shift:=xlToRight Range("A2").Select ActiveCell.FormulaR1C1 = _ "=CONCATENATE(""E:\Users\Tamara\Desktop\MIASTOCK INVENTORY\images\"",RC,"".jpeg"")" Application.Goto Reference:="OFFSET(R2C1,0,0,COUNTA(C3)-1,1)" Selection.FillDown Application.Goto Reference:="OFFSET(R2C1,0,0,COUNTA(C3)-1,1)" Set InputedRange = Range(Selection.Address) For Each C In InputedRange C.RowHeight = 45.5 image = C.Value If File_Exists(image) = True Then Call AddPic(image, C.Offset(0, 1)) Else C.Offset(0, 1).Value = "NO FILE" End If If C.Value = "" Then Exit Sub End If Next C Range("a1").Select Columns(1).EntireColumn.Delete End Sub Sub AddPic(sFile As String, r As Range) With r.Areas(1) ActiveSheet.Shapes.AddPicture FileName:=sFile, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Top:=.Top, Left:=.Left, _ Height:=45, Width:=45 End With End Sub Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean 'Returns True if the passed sPathName exist 'Otherwise returns False On Error Resume Next If sPathName <> "" Then If IsMissing(Directory) Or Directory = False Then File_Exists = (Dir$(sPathName) <> "") Else File_Exists = (Dir$(sPathName, vbDirectory) <> "") End If End If End Function