Excel - A macro to insert pictures

October 2016

Macros in Excel can perform functions such as inserting pictures at locations, copying data from one cell to another etc. Some knowledge of programming concepts such as looping, if-else condition etc. may be required to write effective macros that can accomplish various tasks. Adding loops in macros to insert pictures will ensure that pictures are inserted for all the rows of the Excel worksheet. Without adding loops in macros, it is difficult to perform repetitive actions. If the number of iterations required is not finite, the do-while loop can be used in a macro for inserting pictures in Excel Office Software.


Issue

Could someone please help me in writing a loop in this macro in Excel:
I have an Excel sheet which contains the name of the pictures in column B. I have written a macro to pick up the name of the picture in column B and insert the actual picture from the directory into column A.
I need to create a loop to do this depending on the number of pictures in the B column. The number of rows varies from 10 to 1000.
The macro that I have written works perfectly for the first row but does not go to the next row since I am not sure how to do it.


Please see the macro that I've written:

Sub Picture()
Range("A6").Select 'This is where picture will be inserted
Dim picname As String
picname = Range("B6") 'This is the picture name
ActiveSheet.Pictures.Insert("C:\Users\vbayat\My Documents\vidabayat\re-market\" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("A6").Left
.Top = Range("A6").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub

Solution

Assumptions
  • 1. Picture names are found in col B starting at B2
  • 2. You want to paste each picture at different location
  • 3. Where to paste the picture identified in col B, is found in col C starting at C2


Sub Picture()   
Dim picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

lThisRow = 2

Do While (Cells(lThisRow, 2) <> "")

'Range("A6").Select 'This is where picture will be inserted
pasteAt = Cells(lThisRow, 3)
Cells(pasteAt, 1).Select 'This is where picture will be inserted

'Dim picname As String
'picname = Range("B6") 'This is the picture name
picname = Cells(lThisRow, 2) 'This is the picture name

ActiveSheet.Pictures.Insert("C:\Users\vbayat\My Documents\vidabayat\re-market\" & picname & ".jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With

lThisRow = lThisRow + 1

Loop

Range("A10").Select
Application.ScreenUpdating = True

Exit Sub

ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
Exit Sub
Range("B20").Select

End Sub

Note

Thanks to rizvisa1 for this tip on the forum.

Related :

This document entitled « Excel - A macro to insert pictures » from CCM (ccm.net) is made available under the Creative Commons license. You can copy, modify copies of this page, under the conditions stipulated by the license, as this note appears clearly.