VBA code running slow in Excel 2010

[akin123]

Hey guys,
I have this outrun VBA code that loops a string that places thousands of images in an excel spreadsheet. It starts out running pretty fast but as the images add up in the spreadsheet it eventually grinds to a halt. I need some help fixing the slow pace it runs at toward the end of the process. The whole process ran fine through and through in Excel 2003. We are upgrading and need to be able to run this program in Excel 2010. Please reply with help asap. Thanks.

Here is the code we are using:

'==============================
' This Sub does the Burl Survey Stitching
'============================
Sub Burls()
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 45
files = 0
Const nmax = 15000

Dim ffilename(1 To nmax) As String

Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll

'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3

Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0

dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)

'------------ First Group of Files - Seal Left -----------------
r = 2
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "SL-lft*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 1.5 Group of Files - Seal Rt -----------------
r = 53
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "SL-Rgt*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r - 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ 2nd Group of Files - BT -----------------
r = 5
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "BT-_*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BB -----------------
r = 50
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "BB-_*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 3rd Group of Files - BE1C, BE2C, BE3C, BE4C -----------------
r = 6
c = 6
n = 1
i = 1
For Z = 1 To 4
rootname = "BE" + Trim(Z) + "C-"
If (Z = 1 Or Z = 4) Then
Imax = 12
Else
Imax = 10
End If
For U = 1 To Imax
If (U < 10) Then
Irow = "_I00" & Trim(U)
Else
Irow = "_I0" & Trim(U)
End If
For D = 1 To 45
If (D < 10) Then
Drow = "_D00" & Trim(D)
Else
Drow = "_D0" & Trim(D)
End If
ffilename(i) = dirname + rootname + Drow + Irow + ".jpg"
PlaceImage ffilename(i), r - 1 + U, c - 1 + D
Next D
Next U
r = r + Imax
Next Z
'------------ 4th Group of Files - Seal Lwr -----------------
r = 50
c = 2
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "SL-lwr*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
If i = n * columns_s Then
r = 50
c = c + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 5th Group of Files - Seal Upr -----------------
r = 50
c = 54
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "SL_UPR*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
If i = n * columns_s Then
r = 50
c = c - 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend

'------------ Group of Files - BLR1_D001 -----------------
r = 8
c = 5
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "BLR1-_D001*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR1_D002 -----------------
r = 17
c = 51
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "BLR1-_D002*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR4_D001 -----------------
r = 38
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BLR4-_D001*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
''------------ Group of Files - BLR4_D002 -----------------
r = 38
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BLR4-_D002*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMRU -----------------
r = 18
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRU*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMRL -----------------
r = 28
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRL*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMLU -----------------
r = 18
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLU*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMLL -----------------
r = 28
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLL*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend

'------------ Group of Files - BMLC -----------------
r = 27
c = 4
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLC*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
''------------ Group of Files - BMRC -----------------
r = 27
c = 52
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRC*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - Part ID -----------------
r = 54
c = 26
n = 1
i = 1
ffilename(i) = Dir(dirname + "Prt_ID*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - TS -----------------
ffilename(i) = Dir(dirname + "TS4-_D001_I001.jpg")
PlaceImage dirname + ffilename(i), 54, 14
ffilename(i) = Dir(dirname + "TS4-_D002_I001.jpg")
PlaceImage dirname + ffilename(i), 54, 42
ffilename(i) = Dir(dirname + "TS4-_D001_I002.jpg")
PlaceImage dirname + ffilename(i), 1, 14
ffilename(i) = Dir(dirname + "TS4-_D002_I002.jpg")
PlaceImage dirname + ffilename(i), 1, 42
End Sub
'=======================================
' This sub does the full-grid survey
'=======================================
Sub Full_Grid()
'
' Macro recorded 8/3/99 by tuitterd
'
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 58
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll

'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
ffilename(i) = Dir(dirname + "*.jpg")
'Determine amount of files
While Len(ffilename(i)) > 0
ffilename(i) = Dir()
files = files + 1
Wend
beginrow = 2 * files + 2
ffilename(i) = Dir(dirname + "*.jpg")

'Get data
While Len(ffilename(i)) > 0

Cells(r, c).Select

ActiveSheet.Pictures.Insert(filename:=dirname + ffilename(i)).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=dirname + ffilename(i)

c = c + 1

If i = n * columns_s Then
c = 1
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If

i = i + 1
ffilename(i) = Dir()
Wend

End Sub
'======================================
' This sub does the full-grid survey
'======================================
Sub WFull_Grid()
'
' Macro recorded 8/3/99 by tuitterd
'
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 113
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll

'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
ffilename(i) = Dir(dirname + "*.jpg")
'Determine amount of files
While Len(ffilename(i)) > 0
ffilename(i) = Dir()
files = files + 1
Wend
beginrow = 2 * files + 2
ffilename(i) = Dir(dirname + "*.jpg")

'Get data
While Len(ffilename(i)) > 0

Cells(r, c).Select

ActiveSheet.Pictures.Insert(filename:=dirname + ffilename(i)).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=dirname + ffilename(i)

c = c + 1

If i = n * columns_s Then
c = 1
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If

i = i + 1
ffilename(i) = Dir()
Wend

End Sub
Sub ClearAll()
Cells.Select
Selection.ColumnWidth = 7.2
Selection.RowHeight = 36
End Sub
Sub PlaceImage(xfilename As String, row As Variant, col As Variant)
Cells(row, col).Select
ActiveSheet.Pictures.Insert(filename:=xfilename).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=xfilename
End Sub
Sub Mark_BdImage()
Sheets("Bad_Images").Select
numpts = Cells(1, 2).Value

strtrw = 7
endrw = 7 + numpts - 1

For i = strtrw To endrw
Sheets("Bad_Images").Select
'imgrow = Cells(i, 2).Value
'imgcol = Cells(i, 3).Value
pictnum = Cells(i, 4).Value
pictstr = "Picture " & pictnum

Sheets("Output1").Select
ActiveSheet.Shapes(pictstr).Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Next i
End Sub
Sub Clear_BdImage()
Sheets("Bad_Images").Select
numpts = Cells(1, 2).Value

strtrw = 7
endrw = 7 + numpts - 1

For i = strtrw To endrw
Sheets("Bad_Images").Select
'imgrow = Cells(i, 2).Value
'imgcol = Cells(i, 3).Value
'pictnum = imgrow * imgcol
pictnum = Cells(i, 4).Value
pictstr = "Picture " & pictnum

Sheets("Output1").Select
ActiveSheet.Shapes(pictstr).Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
Next i
End Sub

 

[pbornemeier]

Welcome to the Board!
Please review the links in my sig, especially #3 & #5

Speed boosters:
-- I find the suggestions here are quite useful.
-- The last line here shows why it is best to use Option Explicit

To assist future maintainers of your code (including yourself 1 year after writing your code) consider the following:
-- Procedures in this post show how to automatically indent your code for better readability.
-- VBA allows the use of long variable names. Using r, i, c, n variables (row, column, number, instance ??) short names make it tough to figure out what is going on with the continually changing values.
-- Good start on the comments, but is this comment's meaning clear to all ? ' ---------- 1.5 Group of Files - Seal Rt ----------
-- Naming Conventions
-- All of the several sets of repeated blocks of code could be optimized by populating an array with all variable values from a range in a worksheet. An example fpr the 5-variable chunks f follows:

Option Explicit

Sub AChunkOfYourCode()
  Dim ary5Var As Variant        'Store values for 5 variable loops (lRow, lCol, lIncrement, lN
  Dim iCounterX As Integer       'Looping value
  Dim sDirname As String        'File directory
  Dim sFileNamePrefix As String 'File name prefix
  Dim lFinalFilename As Variant 'PathName+FileNamePrefix+FileNameSuffix
  Dim lRow As Long              'Row where image will be placed
  Dim lCol As Long              'Colimn where image wil be placed
  Dim lIncrement As Long                'Incementing Counter for lFinalFilename
  Dim lN As Long                '?
  
  ary5Var = Worksheets("ArrayVariables").Range("A1:E20")
  sDirname = Worksheets("ArrayVariables").Range("G1")
  
  For iCounterX = 1 To 20

    lRow = ary5Var(iCounterX, 1)
    lCol = ary5Var(iCounterX, 3)
    lIncrement = ary5Var(iCounterX, 2)
    lN = ary5Var(iCounterX, 4)
    lFinalFilename(lIncrement) = Dir(sDirname + ary5Var(iCounterX, 5))
    While Len(lFinalFilename(lIncrement)) > 0
        PlaceImage sDirname + lFinalFilename(lIncrement), lRow, lCol
        lRow = lRow + 1
        lIncrement = lIncrement + 1
        lFinalFilename(lIncrement) = Dir()
    Wend
  
  Next

End Sub