Forum Discussion
VBA help for a Macro (inserting picture from file)
Brady-
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.
- SiamahdOct 03, 2022Copper Contributor
Thank you very much, indeed!
I just modified your code to override Aspect Ratio:
Sub GetPic()
Dim fNameAndPath As Variant
Dim img As Object
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....
.ShapeRange.LockAspectRatio = msoFalse
.Left = ActiveSheet.Range("A5").Left
.Top = ActiveSheet.Range("A5").Top
.Width = ActiveSheet.Range("A5:G5").Width
.Height = ActiveSheet.Range("A5:A20").Height
.Placement = 1
.PrintObject = True
End With
End Sub - regcurlee67Oct 14, 2020Copper ContributorThis works great except it is not placing my picture according to size and location. Some pictures are thin some are wide and the don't land exactly where I told them too.
- GaryIntownJul 31, 2020Copper Contributor
Great tool. Do you know if there is away instead of specifying the exact cell that you could have it say in the adjacent cell. I have a spreadsheet that I would like to use this Macro several times but instead of having multiple macros each specifying each cell can I make it dependent on the button?
- creemacdMay 09, 2020Copper Contributor
Matt Mickle This is great. But could you suggest how I could embed the photos within the document as opposed to being a link
- NSEEK7Mar 26, 2020Copper Contributor
This was great! is there a way to allow multiple uploads at once?
- tghendrickNov 26, 2019Copper Contributor
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[2],"".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
- TsengeeOct 14, 2019Copper Contributor
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.
- dklein_14Mar 20, 2019Copper Contributor
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?
- juan_GuerraApr 10, 2024Copper Contributor
dklein_14 ¿Cómo me vas a decir que te funcionó? Eso ¡no funciona!. Debe ser por la mala traducción al español.
¿Pueden bajar la macro sin traducirla? ¿Es posible?
- Matt MickleMar 20, 2019Bronze Contributor
Hey dklein_14-
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?
-Matt
- dklein_14Mar 21, 2019Copper Contributor
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
2
.Left = ActiveSheet.Range("q33").Left
.Top = ActiveSheet.Range("q33").Top
.Width = ActiveSheet.Range("q33:q38").Width
.Height = ActiveSheet.Range("r33:r38").Height
3
.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.
Title Page
.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!