7
\$\begingroup\$

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
\$\endgroup\$
6
\$\begingroup\$

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.