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 &amp; "\"
    .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) &lt;&gt; "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 &amp; "\" &amp; PicName &amp; ".jpg")

    If present &lt;&gt; "" Then

        ActiveSheet.Pictures.Insert(FldrName &amp; "\" &amp; PicName &amp; ".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 &amp; "\"
        .Title = "Select the folder containing the Image/PDF files."
        .Show

        If .SelectedItems.Count &gt; 0 Then
            selectedFolder = .SelectedItems(1)
            If Right$(selectedFolder, 1) &lt;&gt; Application.PathSeparator Then _
                selectedFolder = selectedFolder &amp; 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 &amp; picName &amp; ".jpg"

        If Len(Dir(picFullName)) &gt; 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 &amp; "\"
        .Title = "Select the folder containing the Image/PDF files."
        .Show

        If .SelectedItems.Count &gt; 0 Then
            selectedFolder = .SelectedItems(1)
            If Right$(selectedFolder, 1) &lt;&gt; Application.PathSeparator Then _
                selectedFolder = selectedFolder &amp; Application.PathSeparator
        End If

    End With
    GetFolder = selectedFolder

End Function