Finding and pasting images into a specific cell

Question

The below macro finds and pastes images into column A. While the macro works, it starts to slow down when running 500+ images. I am not too familiar with the VBA language, does anyone have any suggestions to make this code quicker and/or more elegant?

My existing Macro is as follows:

 Sub Picture() 'This Sub Looks for Image names posted in column B
 'in the file folder and then resizes the images and pastes them
 'in Column A
 'Opens File Dialog Box to select File Folder
 With Application.FileDialog(msoFileDialogFolderPicker)
 .InitialFileName = Application.DefaultFilePath & "\"
 .Title = "Select the folder containing the Image/PDF files."
 .Show
 If .SelectedItems.Count = 0 Then
 Exit Sub
 Else
 FldrName = .SelectedItems(1)
 End If
 End With
 Dim PicName As String
 Dim pasteAt As Integer
 Dim lThisRow As Long
 Application.ScreenUpdating = False
 lThisRow = 2
 Do While (Cells(lThisRow, 2) <> "Please Check Data Sheet")
 pasteAt = lThisRow
 Cells(pasteAt, 1).Select 'This is where picture will be inserted
 PicName = Cells(lThisRow, 2) 'This is the picture name
 present = Dir(FldrName & "\" & PicName & ".jpg")
 If present <> "" Then
 ActiveSheet.Pictures.Insert(FldrName & "\" & PicName & ".jpg").Select 'Path to where pictures are stored
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ' This resizes the picture
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''
 With Selection
 .ShapeRange.LockAspectRatio = msoFalse
 .Height = ActiveCell.Height
 .Width = ActiveCell.Width
 .Top = ActiveCell.Top
 .Left = ActiveCell.Left
 .Placement = xlMoveAndSize
 End With
 Else
 Cells(pasteAt, 1) = "No Picture Found"
 End If
 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

Answer 1

I'm not sure I can make it faster but hopefully can make it a bit elegant. Let's start

First of all, use Option Explicit for all your VBA work. This will make your life easier once you use VBA more.

Error handling Great you use it, unfortunately not correctly. Your label will never be hit

ErrNoPhoto:

You have to tell your code you want to handle errors

On Error Goto ErrNoPhoto

A cosmetic change I changed and mainly moved the code for selecting folder to a separate method, just to make it clear

Private Function GetFolder() As String
 Dim selectedFolder As String
 With Application.FileDialog(msoFileDialogFolderPicker)
 .InitialFileName = Application.DefaultFilePath & "\"
 .Title = "Select the folder containing the Image/PDF files."
 .Show
 If .SelectedItems.Count > 0 Then
 selectedFolder = .SelectedItems(1)
 If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
 selectedFolder = selectedFolder & Application.PathSeparator
 End If
 End With
 GetFolder = selectedFolder
End Function

One of the biggest change I made in your code is changing the way how you go through cells. This can be one of the most slowly operation in VBA.

I always try to convert it to an array which is "million" times faster than going directly through cells. You will see significant difference if you go through huge numbers of cells. I'm not sure you will see the difference in your code but this is one of the best practice.

Set wks = ActiveSheet
' this is not bulletproof but for now should work fine
lastRow = wks.Cells(1, "B").End(xlDown).Row
data = wks.Range(wks.Cells(1, "B"), wks.Cells(lastRow, "B")).Value2

this will load data from cells from column B, from cell B1 to Bn where n is the last row found by this

lastRow = wks.Cells(1, "B").End(xlDown).Row

this will give you an opportunity to use For Next loop instead While. I didn't find anything important I could change in the insert picture logic except one thing that I removed all the Selection command from your code which should again make it a bit faster.

At the end this is what was in my VBE Inserting 800 images took about 7 seconds

Option Explicit
'********************************************************************************
'Picture
'
' Purpose: Looks for Image names posted in column B in the file folder and
' then resizes the images and pastes them in Column A
'
' Inputs: -none-
'
' Outputs: -none-
'
' Created: 06/03/2015 proxy
'
' Modified: .
'
'********************************************************************************
Sub Picture()
 Const EXIT_TEXT As String = "Please Check Data Sheet"
 Const NO_PICTURE_FOUND As String = "No picture found"
 Dim picName As String
 Dim picFullName As String
 Dim rowIndex As Long
 Dim lastRow As Long
 Dim selectedFolder As String
 Dim data() As Variant
 Dim wks As Worksheet
 Dim cell As Range
 Dim pic As Picture
 On Error GoTo ErrorHandler
 selectedFolder = GetFolder
 If Len(selectedFolder) = 0 Then GoTo ExitRoutine
 Application.ScreenUpdating = False
 Set wks = ActiveSheet
 ' this is not bulletproof but for now should work fine
 lastRow = wks.Cells(1, "B").End(xlDown).Row
 data = wks.Range(wks.Cells(1, "B"), wks.Cells(lastRow, "B")).Value2
 For rowIndex = 1 To UBound(data, 1)
 If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine
 picName = data(rowIndex, 1)
 picFullName = selectedFolder & picName & ".jpg"
 If Len(Dir(picFullName)) > 0 Then
 Set cell = wks.Cells(rowIndex, "A")
 Set pic = wks.Pictures.Insert(picFullName)
 With pic
 .ShapeRange.LockAspectRatio = msoFalse
 .Height = cell.Height
 .Width = cell.Width
 .Top = cell.Top
 .Left = cell.Left
 .Placement = xlMoveAndSize
 End With
 Else
 wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
 End If
 Next rowIndex
 Range("A10").Select
ExitRoutine:
 Set wks = Nothing
 Set pic = Nothing
 Application.ScreenUpdating = True
 Exit Sub
ErrorHandler:
 Range("B20").Select
 MsgBox Prompt:="Unable to find photo", _
 Title:="An error occured", _
 Buttons:=vbExclamation
 Resume ExitRoutine
End Sub
Private Function GetFolder() As String
 Dim selectedFolder As String
 With Application.FileDialog(msoFileDialogFolderPicker)
 .InitialFileName = Application.DefaultFilePath & "\"
 .Title = "Select the folder containing the Image/PDF files."
 .Show
 If .SelectedItems.Count > 0 Then
 selectedFolder = .SelectedItems(1)
 If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
 selectedFolder = selectedFolder & Application.PathSeparator
 End If
 End With
 GetFolder = selectedFolder
End Function

• proxy156: That works perfectly. Tested it with 3000 images and it ran in under a minute. In the same excel file, I have a second button to clear all the images. This is a very small code, but runs slowly. I was wondering if you could give it a quick look? Sub DeleteAllPics() Columns("A:A").Replace What:="No Picture Found", Replacement:="", LookAt:=xlPart Dim pic As Object For Each pic In ActiveSheet.Pictures pic.Delete Next pic End Sub
• PetLahev: OK the comment formatting is beating me here. I'll try last time, if it doesn't format properly, you will have to live with it :) Sub DeleteAllPics() On Error Resume Next ActiveSheet.DrawingObjects.Delete End Sub
• PetLahev: Looking at my comment again, when I was editing the comment 10 times I removed my text I had there. The code I gave you will delete all pictures on active sheet. So not only in column A If you need really in column A only, try to use the same technique you use now but instead of deleting one by one, try to select them and when you get out from your loop, delete the selection
• proxy156: Your revision works really fast, my previous code took around 45 sec to delete the pics, your took less than 2 sec. It deletes the pics, but it doesn't remove the "No Picture Found". I added the line of my code that does that to yours and when I went to test it I noticed that your code deleted the button commands I have placed in A1 that Run or Clear the sheet. Is there a simple way to get it to ignore the first row?
• PetLahev: I'm afraid that then you will have to stick with your for each approach. Please send another question I'll send you a code you might like but there is no way I'll format it here in this comment :)