Embed images from folder to Excel column in multiple rows using macro

Excel Image Embedding

do_insertPic will embeds all the images in to excel cell.
do_insertPic1  will just link to physical path of image so you can not copy and use excel file in other PC.

Example: All my image path is mentioned in column A, I am embedding all images in Column C which is 500 from A

Option Explicit

Sub pic()
Dim MyRange As String
 Dim picname As String
 Dim mySelectRange As String
 Dim rcell As Range
 Dim IntInstr As Integer
 Dim Mypath As String

 Mypath = "D:\Career\"
 MyRange = "A2:A5000"

 Range(MyRange).Select
 For Each rcell In Selection.Cells
    If Len(rcell.Value) > 0 Then
        picname = Mypath & rcell.Value & ".jpg"
        mySelectRange = Replace(MyRange, "B", "A")
        IntInstr = InStr(mySelectRange, ":")
        mySelectRange = Left(mySelectRange, IntInstr - 1)
        do_insertPic picname, mySelectRange, rcell.Left + 500, rcell.Top
     End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Long)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

      With ActiveSheet.Shapes.AddPicture(Filename:=picname, _
                                       LinkToFile:=msoFalse, _
                                       SaveWithDocument:=msoTrue, _
                                       Left:=myleft, _
                                       Top:=mytop, _
                                       Width:=80, _
                                       Height:=80)
        .Placement = 1
        .ControlFormat.PrintObject = True
        .LockAspectRatio = msoFalse
   
    End With
ErrNoPhoto:
 'MsgBox "Unable to Find Photo" & picname 'Shows message box if picture not found
 'Exit Sub
End Sub
Private Sub do_insertPic1(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Long)
    Dim rcell As Range
    Range(MyRange).Select
    On Error GoTo ErrNoPhoto

    ActiveSheet.Pictures.Insert(picname).Select
    On Error GoTo 0

    With Selection
     .Left = myleft
     .Top = mytop
     .ShapeRange.LockAspectRatio = msoFalse
     .ShapeRange.Height = 80#
     .ShapeRange.Width = 80#
     .ShapeRange.Rotation = 0#
    End With
Exit Sub
ErrNoPhoto:
 'MsgBox "Unable to Find Photo" & picname 'Shows message box if picture not found
 'Exit Sub
End Sub



written by
Vinod Kotiya