# Finding and pasting images into a specific cell

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


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

• 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 – proxy156 Jun 3 '15 at 23:18
• 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 Jun 4 '15 at 7:59
• 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 – PetLahev Jun 4 '15 at 9:14
• 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? – proxy156 Jun 4 '15 at 16:21
• 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 :) – PetLahev Jun 4 '15 at 19:25