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
