**Optimizing your workbook**

As you search the Internet trying to get some insight as to why your workbook takes
multiple seconds to recalaculate you will find plenty of advice about speeding
up VB code, avoiding array formulas, volatile functions, sumproduct and so on.
This is all good advice, but when you come to apply it its always hard to find
exactly where in the workbook the problem is, and whether the incremental changes
you make have actually made any difference. The best way to optimize is to find
out what is taking the most time and tune it, always checking that the effect
was what you intended.

**Turning general advice into specific action
**Do a google search on "Optimizing Excel". I got 758,000 entries when i
tried it a minute ago. Most of this is good stuff, but usually you need to apply
it as part of your general techniques when you are develeoping the workbook in
the first place. You are reading this article because it's already too late.
You didn't follow the advice, or perhaps you didn't know, or perhaps your workbook
is just really complicated.

What you really want to ask is

**What does the output look like
**What we are looking to produce is a sheet that shows how long it takes to execute
each column in your workbook, that will look like this. C1 is the total for all
columns in seconds, and the percentage time for each column is shown below. This
list will be sorted in decending order so the worst column that you need to go
look at will always be at the top.

**How to add to your workbook
**

You can download the source, and an example workbook from here

or you can workthrough the following

First create a blank tab called "ExecutionTimes", this will be where the results get posted during each profiling activity.

Now create a module, lets call it Optimize. and enter the first sub as below. This sub will run through each column of a given worksheet, timing how long each one takes, and recording the result in the executiontimes tab. The Module is also provided as an attachment to this article.

Option Explicit

Private Declare Function getFrequency Lib "kernel32" _

Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long

Private Declare Function getTickCount Lib "kernel32" _

Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

Function timeSheet(ws As Worksheet, routput As Range) As Range

Dim ro As Range

Dim c As Range, ct As Range, rt As Range, u As Range

ws.Activate

Set u = ws.UsedRange

Set ct = u.Resize(1)

Set ro = routput

For Each c In ct.Columns

Set ro = ro.Offset(1)

Set rt = c.Resize(u.Rows.Count)

rt.Select

ro.Cells(1, 1).Value = rt.Worksheet.Name & "!" & rt.Address

ro.Cells(1, 2) = shortCalcTimer(rt, False)

Next c

Set timeSheet = ro

End Function

Sub timeallsheets()

Call timeloopSheets

End Sub

Sub timeloopSheets(Optional wsingle As Worksheet)

Dim ws As Worksheet, ro As Range, rAll As Range

Dim rKey As Range, r As Range, rSum As Range

Const where = "ExecutionTimes!a1"

Set ro = Range(where)

ro.Worksheet.Cells.ClearContents

Set rAll = ro

'headers

rAll.Cells(1, 1).Value = "address"

rAll.Cells(1, 2).Value = "time"

If wsingle Is Nothing Then

' all sheets

For Each ws In Worksheets

Set ro = timeSheet(ws, ro)

Next ws

Else

' or just a single one

Set ro = timeSheet(wsingle, ro)

End If

'now sort results, if there are any

If ro.Row > rAll.Row Then

Set rAll = rAll.Resize(ro.Row - rAll.Row + 1, 2)

Set rKey = rAll.Offset(1, 1).Resize(rAll.Rows.Count - 1, 1)

' sort highest to lowest execution time

With rAll.Worksheet.Sort

.SortFields.Clear

.SortFields.Add Key:=rKey, _

SortOn:=xlSortOnValues, Order:=xlDescending, _

DataOption:=xlSortNormal

.SetRange rAll

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

' sum times

Set rSum = rAll.Cells(1, 3)

rSum.Formula = "=sum(" & rKey.Address & ")"

' %ages formulas

For Each r In rKey.Cells

r.Offset(, 1).Formula = "=" & r.Address & "/" & rSum.Address

r.Offset(, 1).NumberFormat = "0.00%"

Next r

End If

rAll.Worksheet.Activate

End Sub

Function shortCalcTimer(rt As Range, Optional bReport As Boolean = True) As Double

Dim dTime As Double

Dim sCalcType As String

Dim lCalcSave As Long

Dim bIterSave As Boolean

'

On Error GoTo Errhandl

' Save calculation settings.

lCalcSave = Application.Calculation

bIterSave = Application.Iteration

If Application.Calculation <> xlCalculationManual Then

Application.Calculation = xlCalculationManual

End If

' Switch off iteration.

If Application.Iteration <> False Then

Application.Iteration = False

End If

' Get start time.

dTime = MicroTimer

If Val(Application.Version) >= 12 Then

rt.CalculateRowMajorOrder

Else

rt.Calculate

End If

' Calc duration.

sCalcType = "Calculate " & CStr(rt.Count) & _

" Cell(s) in Selected Range: " & rt.Address

dTime = MicroTimer - dTime

On Error GoTo 0

dTime = Round(dTime, 5)

If bReport Then

MsgBox sCalcType & " " & CStr(dTime) & " Seconds"

End If

shortCalcTimer = dTime

Finish:

' Restore calculation settings.

If Application.Calculation <> lCalcSave Then

Application.Calculation = lCalcSave

End If

If Application.Iteration <> bIterSave Then

Application.Calculation = bIterSave

End If

Exit Function

Errhandl:

On Error GoTo 0

MsgBox "Unable to Calculate " & sCalcType, _

vbOKOnly + vbCritical, "CalcTimer"

GoTo Finish

End Function

'

Function MicroTimer() As Double

'

' Returns seconds.

'

Dim cyTicks1 As Currency

Static cyFrequency As Currency

'

MicroTimer = 0

' Get frequency.

If cyFrequency = 0 Then getFrequency cyFrequency

' Get ticks.

getTickCount cyTicks1

' Seconds

If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency

End Function

Private Declare Function getFrequency Lib "kernel32" _

Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long

Private Declare Function getTickCount Lib "kernel32" _

Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

Function timeSheet(ws As Worksheet, routput As Range) As Range

Dim ro As Range

Dim c As Range, ct As Range, rt As Range, u As Range

ws.Activate

Set u = ws.UsedRange

Set ct = u.Resize(1)

Set ro = routput

For Each c In ct.Columns

Set ro = ro.Offset(1)

Set rt = c.Resize(u.Rows.Count)

rt.Select

ro.Cells(1, 1).Value = rt.Worksheet.Name & "!" & rt.Address

ro.Cells(1, 2) = shortCalcTimer(rt, False)

Next c

Set timeSheet = ro

End Function

Sub timeallsheets()

Call timeloopSheets

End Sub

Sub timeloopSheets(Optional wsingle As Worksheet)

Dim ws As Worksheet, ro As Range, rAll As Range

Dim rKey As Range, r As Range, rSum As Range

Const where = "ExecutionTimes!a1"

Set ro = Range(where)

ro.Worksheet.Cells.ClearContents

Set rAll = ro

'headers

rAll.Cells(1, 1).Value = "address"

rAll.Cells(1, 2).Value = "time"

If wsingle Is Nothing Then

' all sheets

For Each ws In Worksheets

Set ro = timeSheet(ws, ro)

Next ws

Else

' or just a single one

Set ro = timeSheet(wsingle, ro)

End If

'now sort results, if there are any

If ro.Row > rAll.Row Then

Set rAll = rAll.Resize(ro.Row - rAll.Row + 1, 2)

Set rKey = rAll.Offset(1, 1).Resize(rAll.Rows.Count - 1, 1)

' sort highest to lowest execution time

With rAll.Worksheet.Sort

.SortFields.Clear

.SortFields.Add Key:=rKey, _

SortOn:=xlSortOnValues, Order:=xlDescending, _

DataOption:=xlSortNormal

.SetRange rAll

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

' sum times

Set rSum = rAll.Cells(1, 3)

rSum.Formula = "=sum(" & rKey.Address & ")"

' %ages formulas

For Each r In rKey.Cells

r.Offset(, 1).Formula = "=" & r.Address & "/" & rSum.Address

r.Offset(, 1).NumberFormat = "0.00%"

Next r

End If

rAll.Worksheet.Activate

End Sub

Function shortCalcTimer(rt As Range, Optional bReport As Boolean = True) As Double

Dim dTime As Double

Dim sCalcType As String

Dim lCalcSave As Long

Dim bIterSave As Boolean

'

On Error GoTo Errhandl

' Save calculation settings.

lCalcSave = Application.Calculation

bIterSave = Application.Iteration

If Application.Calculation <> xlCalculationManual Then

Application.Calculation = xlCalculationManual

End If

' Switch off iteration.

If Application.Iteration <> False Then

Application.Iteration = False

End If

' Get start time.

dTime = MicroTimer

If Val(Application.Version) >= 12 Then

rt.CalculateRowMajorOrder

Else

rt.Calculate

End If

' Calc duration.

sCalcType = "Calculate " & CStr(rt.Count) & _

" Cell(s) in Selected Range: " & rt.Address

dTime = MicroTimer - dTime

On Error GoTo 0

dTime = Round(dTime, 5)

If bReport Then

MsgBox sCalcType & " " & CStr(dTime) & " Seconds"

End If

shortCalcTimer = dTime

Finish:

' Restore calculation settings.

If Application.Calculation <> lCalcSave Then

Application.Calculation = lCalcSave

End If

If Application.Iteration <> bIterSave Then

Application.Calculation = bIterSave

End If

Exit Function

Errhandl:

On Error GoTo 0

MsgBox "Unable to Calculate " & sCalcType, _

vbOKOnly + vbCritical, "CalcTimer"

GoTo Finish

End Function

'

Function MicroTimer() As Double

'

' Returns seconds.

'

Dim cyTicks1 As Currency

Static cyFrequency As Currency

'

MicroTimer = 0

' Get frequency.

If cyFrequency = 0 Then getFrequency cyFrequency

' Get ticks.

getTickCount cyTicks1

' Seconds

If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency

End Function

If you do want to run on just one sheet, rather than the whole workbook you can use
this, subsitituting in the worksheet name you want to analyze

Sub timeonesheet()

Call timeloopSheets(Worksheets("LIsts"))

End Sub

**Summary****
**Once you have all this set up, assign timeallsheets() to a command button and you
are good to go. I have purposefully left screenupdating on so you can see the
progress - you can see it slowing down at the slow columns which is quite interesting.
If necessary you can turn off screenupdating at the beginning and end of timeallsheets().

If you found this optimizer useful, you can download additional tools here for VBA profiling and optimization. The source code is included and you can use freely as you wish.

By bruce mcpherson **Popularity** (5968 Views)