Macro runs as long as 60secs on Excel 2003 compared to 2002

[libroos]

Hi,

There's one Excel workbook, which I opened it using Excel 2003 on machine A. I run one of the macro and it took about 60secs. I opened the same Excel workbook on machine B Excel 2003, but it took on 5.2 secs.

I opened the same Excel workbook on Excel 2002 (XP), it took 5.2secs or less. All the machines are running on Windows XP Pro.

Anyone experienced this? What could have contributed to this?

Thks.

Rgds,
libroos

 

[MJPPaba]

Has the macro got a step where a filter is applied and then the visible rows are deleted?

2003 does not work so well with this. Can you post the code?

Cheese

Matt

 

[libroos]

Here's the codes:
-------------------------------------------------
Public FreshSheet As Boolean

' Layout and format a worksheet to record expenses
'
Sub Run_This_First()
FreshSheet = True
StartTime = Timer
With Application
.Calculation = xlManual
.ScreenUpdating = False
.DisplayAlerts = False
End With

Call SetUp_Det_Sht

With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.DisplayAlerts = True
End With
EndTime = Timer
Duration = EndTime - StartTime
MsgBox ("Length of Time to Run SpreadSheet ss.s) = :" & Format(Duration, "00.0"))
FreshSheet = False
End Sub
' Set up a Detailed Worksheet
'
'
Sub SetUp_Det_Sht()
Dim Num_Exp
If FreshSheet Then
For i = 1 To Sheets.Count - 1 'is there a Detail Sheet in workbook?
If Sheets(i).Name = "Detail" Then Sheets(i).Delete
Next i
ExpFile = "New" 'otherwise set up a new sheet and call it Detail
Sheets.Add
ActiveSheet.Name = "Detail"
ExpFilePath = "" 'set file path to indicate brand new
End If

Sheets("Detail").Select
ActiveWindow.DisplayGridlines = False
With Cells.Font
.Name = "Arial"
.Size = 10
End With

' Erase all the extra names in sheet except for key ones
Set nms = ActiveWorkbook.Names
For Each nm In nms
If nm.Name = "Tax_class" _
Or nm.Name = "Expenses" _
Then Else nm.Delete
Next nm

Range("A1").Select
ActiveCell.Formula = "Purpose of Trip:"
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.FontStyle = "Bold"
.Font.Size = 14
End With

Range("A4").Select
ActiveCell.Formula = "Week of:"
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 14
End With
ActiveWorkbook.Names.Add Name:="Week_of", RefersToR1C1:= _
"=Detail!R4C5"

Range("E4").Select 'The actual week of expenses
With Selection
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 12
.Font.ColorIndex = 11 'dark blue
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.RowHeight = xlAutofit
.NumberFormat = "ddd, d/mmm/yy"
End With
FormatRules = "Format example: A:UK Biz trip (non-empl;CHID" & _
Chr(10) & " [Company Code] [:] [Trip Description] " & _
Chr(10) & "[(empl/non-empl)] identifes if trip being reimbursed" & _
Chr(10) & " [AJH[:] / CHID[:]] identifes top level of budget category" & _
Chr(10) & "where ':' forces lowest level of budget category only"
Range("E1:J1").MergeCells = False 'unmerge the cells 1st
Range("E1").Select
Selection.Rows.AutoFit 'insure column E1 is fully displayed
RowH = Selection.RowHeight 'capture the row height for later use
On Error Resume Next 'this will avoid error when trying to delete empty comment
With Range("E1")
.ClearComments
'.Comment.Delete
On Error GoTo 0 'reset so future errors are caught
.AddComment
.Comment.Shape.Width = 150
.Comment.Shape.Height = 100
'.Comment.Shape.TextFrame.AutoSize = True
.Comment.Visible = False
.Comment.Text Text:=FormatRules
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
End With
With Range("E1:G1")
.Rows.AutoFit
.WrapText = True
.MergeCells = True 'this command screws up the row height
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 10
.Font.ColorIndex = xlAutomatic
End With
Rows("1:1").RowHeight = RowH 'reset the row height to what it was.

Range("F4").Select 'The warning indicator that Sun or not...
Selection.Rows.Hidden = False
ActiveCell.Formula = _
"=IF(TEXT(RC[-1],""ddd"")=""Sun"", " & _
""""",TEXT(RC[-1],""ddd"")&""; Not a Sunday; reset date"")"
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 12
.ColorIndex = 3 'Red
End With

Range("E6").Select 'Table Header
ActiveCell.Formula = "Exchange Rate"
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 12
.ColorIndex = 5 'light blue
End With

Range("E7:J7").Select 'Exhg Rate Table Header
With Selection
.RowHeight = 70 'set large enough to include all col headers and no wrap
.WrapText = True
.Orientation = xlHorizontal
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 8 'keep small enough to fit 'Reimburse' in table box
.Font.ColorIndex = 10 'Green
End With

ActiveCell.Formula = "Country"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Currency "
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Exchange Rate to Reimbursed Currency"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Reimbursed Currency"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "Local to US$"
Application.GoTo Reference:="RC[1]"
ActiveCell.Formula = "US$ to Local"
Range("F7:H7").Select 'For three columns in the header
With Selection
.WrapText = True
.Orientation = xlUpward
End With

Range("F8").Formula = "Miles"
Range("H8:H14").HorizontalAlignment = xlCenter
Range("H8:H14").VerticalAlignment = xlCenter
Range("J8").Formula = "0.325" 'this is default mileage reimbur rate
Range("E9").Formula = "United States"
Range("F9").Formula = "US"
Range("H9").Formula = "x" 'set the US as the default currency
Range("I9").Formula = "1"
Range("E7:J14").Select
ActiveWorkbook.Names.Add Name:="Ex_rate", RefersToR1C1:= _
"=Detail!R8C6:R14C10"
frm_PgmSelect.Progress.Caption = "Completed Exchange Rate Table"
frm_PgmSelect.Repaint
' The logic table for the currency calculation:
'1- is cur blank
' (1t)- leave ExRate blanked
' (1f)- 2- is this the reimb cur
' (2t) set ExRate=1
' (2f) 3-is this US2Loc blank
' (3t) 4-is reimb cur Loc2US blank
' (4t) set ExRate=reimb cur US2Loc/(1/this Loc2US)
' (4f) set ExRate=this Loc2US / reimb cur Loc2US
' (3f) 5-is reimb cur Loc2US blank
' (5t) set ExRate= this US2Loc / reimb cur US2Loc
' (5f) set ExRate= (1/this US2Loc)/reimb cur Loc2US

Range("G8").Formula = _
"=IF(RC[-1]="""", """"," & _
"IF(Cell(""type"",RC[1])<>""b"",1," & _
"IF(Cell(""type"",RC[3])=""b""," & _
"IF(Cell(""type"",Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)))=""b""," & _
"Index(R8C10:R14C10,Match(""x"",R8C8:R14C8)) / (1/RC[2]) ," & _
"RC[2] / Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)) )" & _
"," & _
"IF(Cell(""type"",Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)))=""b""," & _
"RC[3] / Index(R8C10:R14C10,Match(""x"",R8C8:R14C8)) ," & _
"(1/RC[3]) / Index(R8C9:R14C9,Match(""x"",R8C8:R14C8)) ))))"
Range("G8").Copy Destination:=Range("G9:G14") 'copy the formula down the table.

Application.Calculation = xlAutomatic 'will need to calculation on to do next part
Set ExRt = Range("Ex_Rate").Offset(1, 2) 'look at ExRate col
Do While Not IsEmpty(ExRt(0, 0))
Cell_Value = ExRt(0, 0).Value
If FreshSheet Then
ExRt(0, 0).NumberFormat = "#,##0.00000" 'for a fresh sheet always use default fmt
Else
If Cell_Value < 50 Then ExRt(0, 0).NumberFormat = "#,##0.00000"
If Cell_Value >= 50 And Cell_Value < 100 Then ExRt(0, 0).NumberFormat = "###.000"
If Cell_Value >= 100 And Cell_Value < 2000 Then ExRt(0, 0).NumberFormat = "###.00"
If Cell_Value >= 2000 Then ExRt(0, 0).NumberFormat = "#,###"
End If
Set ExRt = ExRt.Offset(1, 0) 'jump to next cell down
Loop
For i = 0 To 1 'set format for rightmost cols in ExRate table
Set ExRt = Range("Ex_Rate").Offset(1, 4 + i) 'look 1st at Loc to US$ col
For R = 1 To Range("Ex_Rate").Rows.Count
Cell_Value = ExRt(0, 0).Value
If Cell_Value < 50 Then ExRt(0, 0).NumberFormat = "#,##0.0000" 'will do on empty also
If Cell_Value >= 50 And Cell_Value < 100 Then ExRt(0, 0).NumberFormat = "###.000"
If Cell_Value >= 100 And Cell_Value < 2000 Then ExRt(0, 0).NumberFormat = "###.00"
If Cell_Value >= 2000 Then ExRt(0, 0).NumberFormat = "#,###"
Set ExRt = ExRt.Offset(1, 0)
Next R
Next i

With Selection
.Borders(xlLeft).Weight = xlHairline
.Borders(xlLeft).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlHairline
.Borders(xlRight).ColorIndex = xlAutomatic
.Borders(xlTop).Weight = xlHairline
.Borders(xlTop).ColorIndex = xlAutomatic
.Borders(xlBottom).Weight = xlHairline
.Borders(xlBottom).ColorIndex = xlAutomatic
End With
Selection.BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic

Application.Calculation = xlManual 'turn calculation off from prev part

If FreshSheet Then
Num_Exp = 50 'This variable sets number rows in the Expense table
Else 'A sheet exists, so determine the rows in Expense table
Set nms = ActiveWorkbook.Names
For R = 1 To nms.Count
If (nms(R).Name = "Expenses") Then Exp_Exists = True
Next
Call x_Modify_Rmv_Extra_Rows
Range("E15").Copy Destination:=Range("F15:I15") 'erase any reminants from old versions of sheets
' Count the number of rows in the expense matrix
Num_Exp = 0 'start count at the 17th row
Set c = Range("J18")
Do While (c.Borders(xlBottom).Weight = xlHairline _
And Num_Exp < 200) 'Safety valve: stop after exp exceeds 200
Num_Exp = Num_Exp + 1
Set c = c.Offset(1, 0)
Loop
End If

Range("A16").Select 'Expense Table Header
If FreshSheet Then 'Only reset the word if this is new sheet
ActiveCell.Formula = "Activity"
End If
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 12
.ColorIndex = 5 'Light Blue
End With
frm_PgmSelect.Progress.Caption = "Format Expense Half of Detail Worksheet"
frm_PgmSelect.Repaint
Range("A17").Formula = "Date"
Columns("A").ColumnWidth = 10
Range("A18:A" & Num_Exp + 17).NumberFormat = "d mmm yy"
Range("B17").Formula = "Day"
Columns("B").ColumnWidth = 5
Range("B18").Formula = "=IF(RC[-1]="""","""",TEXT(RC[-1],""ddd""))"
Range("B18").Copy Destination:=Range("B19:B" & Num_Exp + 17)
Range("C17").Formula = "Seq"
Range("C17").Orientation = xlUpward
Columns("C").ColumnWidth = 3
Range("C18:C" & Num_Exp + 17).NumberFormat = "#"
Range("D17").Formula = "Company:Class"
Range("D17").Orientation = 90
Columns("D").ColumnWidth = 7
Range("E17").Formula = "Payeeescription"
Range("E17").ColumnWidth = 33
Range("F17").Formula = "Currency"
Range("F17").Orientation = xlUpward
Columns("F").ColumnWidth = 5

Range("G17").Formula = "Local"
Range("G18:G" & Num_Exp + 17).NumberFormat = "#,##0.00"
' Reformat the Local currency column [Col G] to insure it will fit
If Not FreshSheet Then
If Int(1 + (Log(Application.Max _
(Range("G18:G" & Num_Exp + 17))) / Log(10#))) >= 5 Then
Columns("G").ColumnWidth = 11.5
Else: Columns("G").ColumnWidth = 10
End If
Else
Columns("G").ColumnWidth = 10
End If

Range("H17").Formula = "Paid With (in Cur)"
Range("H17").WrapText = True
Columns("H").ColumnWidth = 8.5 'expanded to accomodate added data
Range("I17").Formula = "$$s from Stmnt"
Columns("I").ColumnWidth = 8
Range("I18:I" & Num_Exp + 17).NumberFormat = "#,##0.00"
Range("J17").Formula = "=""Charged in Reimb Cur (""" & _
" & INDEX(R8C6:R14C6,MATCH(""x"",R8C8:R14C8)) & " & """)"""
Columns("J").ColumnWidth = 10
Range("I17:J17").WrapText = True 'allow wrapping in both hdr columns
Range("J18").Select

'The logic table for the table calculation:
'1- is date blank?
' (1t)- leave Chgd blank
' (1f)- 2- is $$s blank?
' (2t) 3- is Currency blank?
' (3t) Use Local [noStmt,noCur]
' (3f) Local / Lkup ExRate(Cur) [noStmt,hv Cur]
' (2f) 4- is UsingCur blank?
' (4t) 5- is Cur Blank?
' (5t) Use $$s [hvStmt,noUCur, noCur]
' (5f) Use $$s / Lkup ExRate(Cur) [hvStmt,noUCur, Cur]
' (4f) 6- is Currency same as UsingCur?[hvStmt,hvUCur]
' (6t) $$s/ Lkup ExRate(Cur) [hvStmt,hvUCur,Cur sm UCur]
' (6f) $$s/ Lkup ExRate(UCur) [hvStmt,hvUCur,Cur ntsm UCur]

ActiveCell.Formula = _
"=IF(RC[-9]="""",""""," & _
"IF(CELL(""type"",RC[-1])=""b""," & _
"IF(CELL(""type"",RC[-4])=""b""," & _
"RC[-3],INT(100*RC[-3]/VLOOKUP(RC[-4],Ex_rate,2,FALSE)+0.5)/100)," & _
"IF(ISERROR(FIND(""("",RC[-2],2))," & _
"IF(CELL(""type"",RC[-4])=""b""," & _
"RC[-1]," & _
"INT(100*RC[-1]/VLOOKUP(RC[-4],Ex_rate,2,FALSE)+0.5)/100)," & _
"IF(RC[-4]=" & _
"IF(ISERROR(FIND(""("",RC[-2],2)),""""," & _
"MID(RC[-2],1+FIND(""("",RC[-2]),FIND("")"",RC[-2])-FIND(""("",RC[-2])-1))," & _
"INT(100*RC[-1]/VLOOKUP(RC[-4],Ex_rate,2,FALSE)+0.5)/100," & _
"INT(100*RC[-1]/VLOOKUP" & _
"(MID(RC[-2],1+FIND(""("",RC[-2]),FIND("")"",RC[-2])-FIND(""("",RC[-2])-1)," & _
"Ex_rate,2,FALSE)+0.5)/100))))"
ActiveCell.Copy Destination:=Range("J19:J" & Num_Exp + 17)

Range("J18:J" & Num_Exp + 17).Select 'select last currency column to set format
Selection.NumberFormat = """$""#,##0.00;[Red]-""$""#,##0.00"

Range("A17:J17").Select
' Set Column header to bold and set the color
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 9
.ColorIndex = 14 'Blue-Green
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlLeft).Weight = xlHairline
.Borders(xlLeft).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlHairline
.Borders(xlRight).ColorIndex = xlAutomatic
End With
Selection.BorderAround Weight:=xlThin, ColorIndex:=xlAutomatic

Range("A18:J" & Num_Exp + 17).Select ' Place borders around the data
With Selection 'set the detail table to a top orientation, and no wrap
.WrapText = False
.Orientation = xlHorizontal
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Font.FontStyle = "Regular"
.Font.Bold = False
.Font.Size = 9
End With
With Selection
.Borders(xlLeft).Weight = xlHairline
.Borders(xlLeft).ColorIndex = xlAutomatic
.Borders(xlRight).Weight = xlHairline
.Borders(xlRight).ColorIndex = xlAutomatic
.Borders(xlTop).Weight = xlHairline
.Borders(xlTop).ColorIndex = xlAutomatic
.Borders(xlBottom).Weight = xlHairline
.Borders(xlBottom).ColorIndex = xlAutomatic
End With

' Set Alignment formatting exceptions
Range("B18:C" & Num_Exp + 17).HorizontalAlignment = xlCenter
Range("E18:E" & Num_Exp + 17).WrapText = True
Range("G18:G" & Num_Exp + 17).HorizontalAlignment = xlRight
Range("I18:J" & Num_Exp + 17).HorizontalAlignment = xlRight
' Set Color and Font formatting exceptions
Range("B18:B" & Num_Exp + 17).Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.ColorIndex = 30 'Brown
End With

' Insert the sum line and a base currency at bottom of table
Range("J" & Num_Exp + 17 + 1).Formula = _
"=SUM(R[" & -Num_Exp & "]C:R[-1]C)"
Range("I" & Num_Exp + 17 + 1).Formula = _
"=INDEX(R8C6:R14C6,MATCH(""x"",R8C8:R14C8))"
ActiveWorkbook.Names.Add Name:="Expenses", RefersToR1C1:= _
"=Detail!R17C1:R" & Num_Exp + 17 & "C10"

Call SetUp_Det_Pg_4Prnt

frm_PgmSelect.Progress.Caption = "Complete Detail Worksheet"
frm_PgmSelect.Repaint
ActiveSheet.DisplayAutomaticPageBreaks = True
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
ActiveWindow.DisplayFormulas = False
' Set viewing Window to the width of the table
Range("A17:J17").Select
ActiveWindow.Zoom = True
Range("E1").Select 'Place box at first page; trip's purpose
Exit Sub

WarnAbtSheet:
Sheets.Delete
'BoxTitle = "Duplicate Sheets"
'BoxMsg = "Detail Worksheet already exists;" & _
Chr(10) & "Please remove it"
'BoxStyle = vbOKOnly + vbInformation
'BoxResponse = MsgBox(BoxMsg, BoxStyle, BoxTitle)
End Sub
Sub SetUp_Det_Pg_4Prnt()
With ActiveSheet.PageSetup 'reset the parameters when it gets printed
.PrintTitleRows = "$16:$17"
.PrintTitleColumns = ""
.LeftHeader = " "
.CenterHeader = "&14Details of Expenses"
.RightHeader = " "
.LeftFooter = "&8Date Printed: &D"
.CenterFooter = "Page &P"
'.RightFooter = "&8 " & ExpMgmt.ExpFile 'Must be space after FontSize (Excel bug)
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.4)
.PrintGridlines = False
.CenterHorizontally = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
End With

With ActiveWorkbook
.Title = "Expense Sheet"
.Subject = "Expenses " & Range("E4")
.Author = "AJ Haire"
.Keywords = ""
.Comments = Range("E1")
End With
End Sub

' Remove_Excess_Rows Macro
' Eliminate extra rows in the Detail sheet
'
Sub x_Modify_Rmv_Extra_Rows()
' is there a '(' in the Activity cell? Indicates that don't delete rows
If InStrRev(Range("A16"), "(") <= 0 Then

' 1st set the Size of Name:"Expenses" accuratly
Set c = Range("A18")
Num_Exp = 0
Do While Not IsEmpty(c)
Num_Exp = Num_Exp + 1
Set c = c.Offset(1, 0)
Loop
ActiveWorkbook.Names.Add Name:="Expenses", RefersToR1C1:= _
"=Detail!R17C1:R" & Num_Exp + 17 & "C10"

' 2nd sort expense matrix by the date & seq
Application.GoTo Reference:="Expenses"
Selection.Sort Key1:=Range("A18"), Order1:=xlAscending, _
Key2:=Range("C18"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

' Delete the unnecessary rows
c.Range("A1:A50").Select
Selection.EntireRow.Delete
' Store the Sum & Base currency finder functions
Range("J" & Num_Exp + 17 + 1).Select 'The sum line should be below table
ActiveCell.Formula = "=SUM(R[-" & Num_Exp & "]C:R[-1]C)"
Range("I" & Num_Exp + 17 + 1).Select 'Store the base currency
ActiveCell.Formula = "=INDEX(R8C6:R14C6,MATCH(""x"",R8C8:R14C8))"
Else
Flag = Mid(Range("A16"), InStrRev(Range("A16"), "("), _
Len(Range("A16")) - InStrRev(Range("A16"), "(") + 1)

BoxTitle = "Prevent Row Removal"
BoxMsg = "Sheet locked from deleting empty rows;" & _
Chr(10) & "Remove keyword '" & _
Flag & "' from Activity Cell, if appropriate"
BoxStyle = vbOKOnly + vbInformation
BoxResponse = MsgBox(BoxMsg, BoxStyle, BoxTitle)
End If
Range("A17").Select 'Place box at top of expense table
frm_PgmSelect.Progress.Caption = "Await instructions"
frm_PgmSelect.Repaint
End Sub
-------------------------------------------------
Pls advise. Thks.

 

[AnotherHiggins]

libroos :

Because this question is specifically about macros, it would be a better fit in forum707. Please repost your question there.

But that's a lot of code. Please bear in mind that everyone here is a volunteer. We all have 'real' jobs of our own and donate time when we can. What I'm saying is that I doubt anyone is going to go through all of that code in detail for you.

But here's a good troubleshooting step that will help us find the problem: On one of the "problem machines", step through the code one line at a time. You can do that by pressing [F8][red]*[/red]. Go through your code and see if there are any steps that take a really long time. Take note of those lines of code (maybe copy them into word or mark them in your macro) and include them in your new post in forum707.

[red]*[/red]Note: To speed up stepping through loops, you can click on the line of code immediately following the loop process and press [F9]. That will place a stop on that line. Then you can just click run and let the loop go on its own, continuing to press [F8] after it is done.

[tt]_____
[blue]-John[/blue][/tt]
[tab][red]The plural of anecdote is not data[/red]

Help us help you. Please read FAQ 181-2886 before posting.