VBA code running slow in Excel 2010

A

akin123

New Member
Joined
Jun 28, 2012
Messages
1
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
 
Sort by date Sort by votes
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:
Rich (BB code): 
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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

U
  • Solved
Rewrite Code as a Sub to work on Active Sheet
Replies
2
Views
232
Skyybot
Skyybot
A
  • Solved
VBA to run through multiple files in a folder and perform an action
Replies
3
Views
286
Logit
Logit
R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
357
HighAndWilder
H
V
  • Question Question
VBA excel worksheet2 out of range even though the cell is within the range and additional value created
Replies
4
Views
329
MARK858
MARK858
I
  • Solved
Trying to open userform & run code from worksheet but see a compile error message
Replies
4
Views
143
ipbr21054
I

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top