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 

Thank you for your time and help. Please let me know if I need to try to clarify a little more.