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:
Ms

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$(selected

StackExchange Code Review Q#92490, answer score: 6