VBA code - Complicated script that takes forever - Please help me make it smoother

[briangranberg]

Dear Brilliant forum

I have just received a work related task. I have little knowledge of VBA, however, I told my colleagues that this forum has the best Excel/VBA brains out there.

I received a document containing our product sales and an attached macro that sorts these products (and inserts pictures) according to the sales.

I have been asked if I could spot speed improvements in the following code (as it takes forever to load). Can anyone please help me out as to how to make the macro run faster and smoother?

Thanks in advance guys.

Code:

Sub Planogramm()
On Error Resume Next

Dim folderName As String
Dim folderDialog As FileDialog
Dim endRow As Long
Dim rowLoop As Long
Dim myPict As Variant
Dim fileName As String

folderName = "C:\Users\guro\Desktop\All_packshots"

Set folderDialog = Application.FileDialog(msoFileDialogFolderPicker)

With folderDialog

.Title = "Select Image Folder"
.AllowMultiSelect = False
.InitialFileName = folderName

End With

If (folderDialog.Show <> 0) Then

folderName = folderDialog.SelectedItems(1)

If (Right(folderName, 1) <> "\") Then folderName = folderName & "\"

For Each myPict In ActiveSheet.Pictures

myPict.Delete

Next myPict

endRow = Range("A65536").End(xlUp).Row

For rowLoop = 2 To endRow

fileName = Trim(Cells(rowLoop, "A")) & ".png"

If (Dir(folderName & fileName) <> "") Then

ActiveSheet.Shapes.AddPicture folderName & fileName, msoFalse, msoTrue, Cells(rowLoop, "B").Left, Cells(rowLoop, "B").Top, _
Cells(rowLoop, "B").Width, Cells(rowLoop, "B").Height




End If

Next rowLoop

End If

If (1 <> 0) Then


For Each myPict In ActiveSheet.Pictures


Next myPict

endRow = Range("C65536").End(xlUp).Row

For rowLoop = 2 To endRow

fileName = Trim(Cells(rowLoop, "C")) & ".png"

If (Dir(folderName & fileName) <> "") Then

ActiveSheet.Shapes.AddPicture folderName & fileName, msoFalse, msoTrue, Cells(rowLoop, "D").Left, Cells(rowLoop, "D").Top, _
Cells(rowLoop, "D").Width, Cells(rowLoop, "D").Height



End If





Next rowLoop

End If

If (1 <> 0) Then


For Each myPict In ActiveSheet.Pictures


Next myPict

endRow = Range("E65536").End(xlUp).Row

For rowLoop = 2 To endRow

fileName = Trim(Cells(rowLoop, "E")) & ".png"

If (Dir(folderName & fileName) <> "") Then

ActiveSheet.Shapes.AddPicture folderName & fileName, msoFalse, msoTrue, Cells(rowLoop, "F").Left, Cells(rowLoop, "F").Top, _
Cells(rowLoop, "F").Width, Cells(rowLoop, "F").Height



End If





Next rowLoop

End If


If (1 <> 0) Then


For Each myPict In ActiveSheet.Pictures


Next myPict

endRow = Range("G65536").End(xlUp).Row

For rowLoop = 2 To endRow

fileName = Trim(Cells(rowLoop, "G")) & ".png"

If (Dir(folderName & fileName) <> "") Then

ActiveSheet.Shapes.AddPicture folderName & fileName, msoFalse, msoTrue, Cells(rowLoop, "H").Left, Cells(rowLoop, "H").Top, _
Cells(rowLoop, "H").Width, Cells(rowLoop, "H").Height



End If





Next rowLoop

End If


If (1 <> 0) Then


For Each myPict In ActiveSheet.Pictures


Next myPict

endRow = Range("I65536").End(xlUp).Row

For rowLoop = 2 To endRow

fileName = Trim(Cells(rowLoop, "I")) & ".png"

If (Dir(folderName & fileName) <> "") Then

ActiveSheet.Shapes.AddPicture folderName & fileName, msoFalse, msoTrue, Cells(rowLoop, "J").Left, Cells(rowLoop, "J").Top, _
Cells(rowLoop, "J").Width, Cells(rowLoop, "J").Height



End If





Next rowLoop

End If


If (1 <> 0) Then


For Each myPict In ActiveSheet.Pictures


Next myPict

endRow = Range("K65536").End(xlUp).Row

For rowLoop = 2 To endRow

fileName = Trim(Cells(rowLoop, "K")) & ".png"

If (Dir(folderName & fileName) <> "") Then

ActiveSheet.Shapes.AddPicture folderName & fileName, msoFalse, msoTrue, Cells(rowLoop, "L").Left, Cells(rowLoop, "L").Top, _
Cells(rowLoop, "L").Width, Cells(rowLoop, "L").Height



End If





Next rowLoop

End If



End Sub

 

[briangranberg]

anyone?

 

[briangranberg]

bump

 

[shg]

Try

Sub Planogramm()
    Dim sDir        As String
    Dim oPic        As Picture
    Dim iCol        As Long
    Dim iRow        As Long
    Dim sFile       As String

    sDir = "C:\Users\guro\Desktop\All_packshots"

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Image Folder"
        .AllowMultiSelect = False
        .InitialFileName = sDir
        If .Show = 0 Then Exit Sub
        sDir = .SelectedItems(1)
        If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
    End With

    Application.ScreenUpdating = False

    For Each oPic In ActiveSheet.Pictures
        oPic.Delete
    Next oPic

    For iCol = 2 To 9 Step 2
        For iRow = 2 To Cells(Rows.Count, iCol).End(xlUp).Row
            sFile = Trim(Cells(iRow, iCol).Value) & ".png"

            If Len(Dir(sDir & sFile)) Then
                With Cells(iRow, iCol + 1)
                    ActiveSheet.Shapes.AddPicture Filename:=sDir & sFile, _
                                                  LinkToFile:=msoFalse, _
                                                  SaveWithDocument:=msoTrue, _
                                                  Left:=.Left, _
                                                  Tope:=.Top, _
                                                  Width:=.Width, _
                                                  Height:=.Height
                End With
            End If
        Next iRow
    Next iCol

    Application.ScreenUpdating = True
End Sub

 

[shg]

A little clean-up:

Sub Planogramm()
    Dim sDir        As String
    Dim oPic        As Picture
    Dim iCol        As Long
    Dim iRow        As Long
    Dim sFile       As String
    Dim vdLeft      As Variant  ' column left
    Dim vdWidth     As Variant  ' column width

    sDir = "C:\Users\guro\Desktop\All_packshots"

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Image Folder"
        .AllowMultiSelect = False
        .InitialFileName = sDir
        If .Show = 0 Then Exit Sub
        sDir = .SelectedItems(1)
        If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
    End With

    Application.ScreenUpdating = False

    For Each oPic In ActiveSheet.Pictures
        oPic.Delete
    Next oPic

    For iCol = 2 To 9 Step 2
        vdLeft = Columns(iCol).Left
        vdWidth = Columns(iCol).Width
        
        For iRow = 2 To Cells(Rows.Count, iCol).End(xlUp).Row
            sFile = Trim(Cells(iRow, iCol).Value) & ".png"

            If Len(Dir(sDir & sFile)) Then
                With Cells(iRow, iCol + 1)
                    ActiveSheet.Shapes.AddPicture Filename:=sDir & sFile, _
                                                  LinkToFile:=msoFalse, _
                                                  SaveWithDocument:=msoTrue, _
                                                  Left:=vdLeft, _
                                                  Top:=.Top, _
                                                  Width:=vdWidth, _
                                                  Height:=.Height
                End With
            End If
        Next iRow
    Next iCol

    Application.ScreenUpdating = True
End Sub

 

[briangranberg]

Dear SHG

Thank you for your help. We are testing it today to see how it goes. I will return with comments and grattitude regarding outcome.

I dont get how the above becomes what you are proposing, however, I hope that it works

Kind regards
Brian