Originally Posted by
georgiboy
Give the below a try, it looks at the filepaths in column B:
Sub test()
Dim img As Picture
Dim rng As Range
Dim rCell As Range, iRng As Range
' the below sets the range to all of the file paths that exist in column B
Set rng = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeConstants)
On Error Resume Next ' will help us ignore images that do not exist, switch errors off
For Each rCell In rng.Cells ' loop through the range set above
Set img = ActiveSheet.Pictures.Insert(rCell.Value) ' looking at the filepath in column B
Set iRng = rCell.Offset(, -1) ' set a range to the cell where the image is to be placed
With img
.Left = iRng.Left
.Top = iRng.Top
.Width = iRng.Width
.Height = iRng.Height
.Placement = xlMoveAndSize ' how the image is placed (floating, move and size etc...)
.PrintObject = True ' yes or no to print the object
End With
Set img = Nothing ' clear the image in case the next image is missing
Next rCell
On Error GoTo 0 ' turn errors back on
End Sub
Thank you so much! This has really helped me out.
I've adapted it slightly below to use a user selected range for "Set Rng". Eg they select there they want images to land and then it checks the neighbouring cell for the values. I've not been able to re-work the SpecialCells element into the user selected range. Is this important?
Thanks again!!
Sub insertpic()
Dim img As Picture
Dim rng As Range
Dim rCell As Range, iRng As Range
' the below sets the range to all of the file paths that exist in column B
Set rng = Selection.Offset(0, 1).SpecialCells(xlCellTypeConstant)
On Error Resume Next ' will help us ignore images that do not exist, switch errors off
For Each rCell In rng.Cells ' loop through the range set above
Set img = ActiveSheet.Pictures.Insert(rCell.Value) ' looking at the filepath in column B
Set iRng = rCell.Offset(, -1) ' set a range to the cell where the image is to be placed
With img
.Left = iRng.Left + 4
.Top = iRng.Top + 4
.Width = iRng.Width
'.Height = iRng.Height
.Height = 150
iRng.RowHeight = img.Height + 8
.ShapeRange.LockAspectRatio = msoTrue
.Placement = xlMove ' how the image is placed (floating, move and size etc...)
.PrintObject = True ' yes or no to print the object
LinkToFile = msoFalse
SaveWithDocument = msoTrue
End With
Set img = Nothing ' clear the image in case the next image is missing
Next rCell
On Error GoTo 0 ' turn errors back on
End Sub