Excel 2013 Macro runs Extremely Slow !

[Pyro777]

My Accounting team runs a Macro Against a workbook that takes approximately 35 - 50 mins to run. Previously running this Macro on Excel 2003 it took about 2 mins to run... Here are the old and new system settings:

Old System
Windows 7 (32Bit), Office 2003 (4 Gig of Ram) Dual Core Processor, (Actual PC, Not a Virtual

New System:
Windows 7 (64 Bit), Office 2014 (8 Gig of Ram) (Citrix Virtual Desktop), Macro Still Extremely Slow...
(Processors run at about 30-40 % when this macro is running so it is not over taxing the processors) and very little memory usage while running...

Here is the macro coding the team is using. (I cannot provide to workboot due to company Policy)

Any changes/modifications would be very much appreciated !!


Sub rangenamer()

Dim rng1 As Range, sNew_Name As String, bcheck As Boolean

'DELETE NAME RANGES FIRST

Set rng1 = Range("B2")

Do Until IsEmpty(rng1)
sNew_Name = rng1.Offset(0, -1).Value

For Each OName In ActiveWorkbook.Names
If OName.Name = sNew_Name Then ActiveWorkbook.Names(sNew_Name).Delete
Next OName

ActiveWorkbook.Names.Add Name:=sNew_Name, RefersTo:=rng1
Set rng1 = rng1.Offset(1, 0)
Loop
ActiveWorkbook.Names.Add Name:="RENEW_IND", RefersTo:=Range("H2") End Sub

Sub Rate_Current()

'make sure data is sorted by policy number symbol module Dim dPolPrem1 As Double, dPolPrem2 As Double, dcapfact As Double, drencapfact As Double Dim Lstrow As Integer, ncov As Byte, n As Byte, i As Integer, k As Byte, j As Byte


'If match HDB = Y then it wont cap prior .
'If match HDB = N then it will cap prior .
Application.ScreenUpdating = False

ncov = Range("CURRENT_PREMIUMS").Cells.Count
n = Worksheets("Algorithm").Range("CURR_ALGO_PREM").Cells.Count

dPolPrem1 = 0
dPolPrem2 = 0
dcapfact = 1 ' Sheets("cap").Range("J4").Value + 1 Lstrow = Sheets("Data").Range("A10").End(xlDown).Row

For i = 3 To Lstrow

iPointer = Sheets("Data").Range("A" & i).Value

Application.StatusBar = "Row " & i & " of " & Lstrow
Range("RECORD").Offset(i - 2, 0).Copy
Worksheets("Algorithm").Range("B2").PasteSpecial Paste:=xlValue, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

Calculate

If IsError(Worksheets("Algorithm").Range("CURR_ALGO_PREM").Cells.Value) Then MsgBox "Pause"

'Re-rate current

Range("CURRENT_PREMIUMS").Offset(i - 2, 0).Value = Range("CURR_ALGO_PREM").Value
'cumulate policy premium
GoTo jumpovercapping
drencapfact = 1

If iPointer <> Sheets("Data").Range("A" & i - 1).Value Then
jUnit = 0
dPolPrem1 = Range("TOTAL_PRIF").Value
dPolPrem2 = Range("CURR_ALGO_PREM").Cells.Value

Else
jUnit = jUnit + 1
dPolPrem1 = Range("TOTAL_PRIF").Value + dPolPrem1
dPolPrem2 = Range("CURR_ALGO_PREM").Cells.Value + dPolPrem2
End If

If iPointer <> Sheets("Data").Range("A" & i + 1).Value Then
'Newer policies already have cap factor
If Range("RENEW_IND").Value = "N" Then
drencapfact = Range("rnl_cap_factor").Value
ElseIf dcapfact = 1 Then
drencapfact = 1
ElseIf dPolPrem1 <= 1 Then
drencapfact = 1
ElseIf dPolPrem2 / dPolPrem1 > dcapfact Then
drencapfact = (dPolPrem1 * dcapfact) / dPolPrem2
Else
drencapfact = 1
End If


For j = 0 To jUnit
For k = 1 To ncov
dCapPrem = drencapfact * Range("CURRENT_PREMIUMS").Offset(i - 2 - j, 0).Cells(k).Value
Range("CURRENT_PREMIUMS").Offset(i - 2 - j, ncov).Cells(k).Value = Round(dCapPrem, 0)
Next k
Next j
End If
jumpovercapping:
Next i

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

Sub Rate_Filed()
Dim sht As String
Dim dPolPrem1 As Double, dPolPrem2 As Double, dcapfact As Double Dim ncov As Byte, Lstrow As Integer, n As Byte, i As Integer, k As Byte, j As Byte Dim t As Date t = Now() Application.ScreenUpdating = False




dPolPrem1 = 0
dPolPrem2 = 0
dcapfact = Range("Selected_Cap").Value

Sheets("Algorithm").Range("G83").Value = "N"
sht = "Data"
ncov = Range("CURRENT_CAP_PREMIUMS").Cells.Count
n = Worksheets("Algorithm").Range("FILED_ALGO_PREM").Cells.Count

Lge("A10").End(xlDown).Row

For i = 3 To Lstrow

Application.StatusBar = "Row " & i & " of " & Lstrow & "- " & sFactor
Range("RECORD").Offset(i - 2, 0).Copy
Worksheets("Algorithm").Range("B2").PasteSpecial Paste:=xlValue, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

Calculate


If IsError(Worksheets("Algorithm").Range("FILED_ALGO_PREM").Cells.Value) Then MsgBox "Pause"

'Filed rates
Range("FILED_ALGO_PREM").Copy
Sheets("Data").Range("PROJECTED_PREMIUMS").Offset(i - 2, 0).PasteSpecial xlPasteValues
Application.StatusBar = False

Next i

For n = 1 To ncov
newprem = Range(Range("PROJECTED_PREMIUMS").Cells.Offset(1, 0), Range("PROJECTED_PREMIUMS").Cells.End(xlDown)).Address
newpremAmt = Application.WorksheetFunction.Sum(Sheets("Data").Range(newprem))
oldprem = Range(Range("CURRENT_PREMIUMS").Cells.Offset(1, 0), Range("CURRENT_PREMIUMS").Cells.End(xlDown)).Address
oldpremAmt = Application.WorksheetFunction.Sum(Sheets("Data").Range(oldprem))
With myRng.Offset(0, n + 2).Cells(k)
On Error Resume Next
.Value = newpremAmt / oldpremAmt - 1
If Err.Number <> 0 Then
.Value = 0
End If
Err.Clear
.NumberFormat = "0.0%"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
On Error GoTo 0
Next n



newpremAmt = 0
oldpremAmt = 0
Next k

Call Rate_Filed
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True


End Sub


capfact = 1
End If


For j = 0 To jUnit
For k = 1 To ncov
dCapPrem = drencapfact * Range("PROJECTED_PREMIUMS").Offset(i - 2 - j, 0).Cells(k).Value
Range("PROJECTED_PREMIUMS").Offset(i - 2 - j, ncov).Cells(k).Value = Round(dCapPrem, 0)
Next k
Next j

End If


Next i

Application.ScreenUpdating = True
Application.StatusBar = Format(Now() - t, "hh:mm:ss") End Sub


Sub factor_impact()
Dim myRng As Range, newprem As String, oldprem As String Dim frow As Byte, irow As Byte, ncov As Byte, n As Byte, kfact As Byte, k As Byte Dim i As Integer, Lstrow As Integer Dim newpremAmt As Double, oldpremAmt As Double

Application.ScreenUpdating = False


Sheets("Algorithm").Select
'Sheets("Algorithm").Range("E81").Value = "N"

Set myRng = Range(Range("F149"), Range("F149").End(xlDown)) ncov = Range("CURRENT_PREMIUMS").Cells.Count
irow = Range("FILED_CALC").Cells(1).Row


For k = 1 To myRng.Rows.Count
sFactor = myRng(k).Value
If k = myRng.Rows.Count Then
Range("FILED_CALC").Replace what:="Curr", replacement:="Filed", lookat:=xlPart, MatchCase:=False
GoTo jumpy
End If

Range("FILED_CALC").Replace what:="Filed", replacement:="Curr", lookat:=xlPart, MatchCase:=False

If k > 1 Then
On Error Resume Next
frow = Range(Range("F" & irow), Range("F" & irow).End(xlDown)).Find( _
what:=sFactor, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False).Row
On Error GoTo 0
End If
If sFactor = "Driving Record Surch" Then
Rows(frow & ":" & frow + 3).Select
ElseIf sFactor = "Annual Mileage Factor" Then
Rows(frow & ":" & frow + 1).Select
' dummy row
ElseIf sFactor = "GSD / DTD" Then
Range(frow & ":" & frow & "," & frow + 5 & ":" & frow + 5).Select
ElseIf sFactor = "No Change" Then
Rows("1:1").Select
Else
Rows(frow & ":" & frow).Select
End If

'switch factor selected
Selection.Replace what:="Curr", replacement:="Filed", lookat:=xlPart, MatchCase:=False

jumpy:
Lstrow = Sheets("Data").Ran??mC

 

[SkipVought]

Hi,

Check these suggestions

How Can I Make My Code Run Faster? faq707-4105

 

[combo]

Without analysing the logic:
1.There are a lot of [tt]Calculate[/tt] commands in your code. This recalculates all workbooks, depending on their contents may significantly slow down code. The code can be faster if, for macro execution time, you set calculation to manual: [tt]Application.Calculation = xlCalculationManual[/tt] and, if necessary, apply [tt]Calculate[/tt] to required ranges only.
2. You have 3D loops in the code, this will quickly increase number of operations when insreasing data size.
3. Usually picking data range to variant with array (VarArray=YourRange) and working with this variant instead of source range can improve code performance.



combo

 

[Pyro777]

This is why I love this site, you two are awesome !! The only unfortunate item is that I did not create this Macro. I am trying to assist our Accounting team. I am not very strong with Macros in Excel.

Combo,
Do you have any additional coding i can replace in this Macro as i am not very familiar with the syntax..

Once again, Thank you both, you guys Rock !!

 

[zelgar]

My office just went from Excel 2007 in XP to Excel 2010 in Win7. I've noticed that some spreadsheets with macros do not transfer well from one version of Excel to another. A simple solution that may work for you (it did help in some spreadsheets for me) is to basically copy the spreadsheet and macros from the original spreadsheet into a new one.

Logically, this shouldn't make any difference since the data in the cells and the macros are identical, but it sometimes works.

 

[Pyro777]

Thank you for your Quick response on this one Zelgar. Unfortunately i have already tried this and still very slow. I believe it is in the coding per earlier comments but I am not very familiar with the Coding/Syntax...

Once again, thank you for your input !!

 

[Andrzejek]

You may want to ‘isolate’ parts of your code and investigate which parts take the longest time to run. Put some break points in the code separating some chunks of logic and drill down to the most troublesome. I would fix/improve them first.

If you then ask here: this is the part of code that takes way too long to process:[tt]
[some code here][/tt]
I am sure people here at TT will come up with some better/faster way to do it.


Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[Pyro777]

Good Thought Andrzejek... Here is part of that code that is run 90% of the time.

Maybe some assistance with this part then i can work from there ??


Sub Rate_Filed()
Dim sht As String
Dim dPolPrem1 As Double, dPolPrem2 As Double, dcapfact As Double Dim ncov As Byte, Lstrow As Integer, n As Byte, i As Integer, k As Byte, j As Byte Dim t As Date t = Now() Application.ScreenUpdating = False

dPolPrem1 = 0
dPolPrem2 = 0
dcapfact = Range("Selected_Cap").Value

Sheets("Algorithm").Range("G83").Value = "N"
sht = "Data"
ncov = Range("CURRENT_CAP_PREMIUMS").Cells.Count
n = Worksheets("Algorithm").Range("FILED_ALGO_PREM").Cells.Count

Lge("A10").End(xlDown).Row

For i = 3 To Lstrow

Application.StatusBar = "Row " & i & " of " & Lstrow & "- " & sFactor
Range("RECORD").Offset(i - 2, 0).Copy
Worksheets("Algorithm").Range("B2").PasteSpecial Paste:=xlValue, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True

Calculate


If IsError(Worksheets("Algorithm").Range("FILED_ALGO_PREM").Cells.Value) Then MsgBox "Pause"

'Filed rates
Range("FILED_ALGO_PREM").Copy
Sheets("Data").Range("PROJECTED_PREMIUMS").Offset(i - 2, 0).PasteSpecial xlPasteValues
Application.StatusBar = False

Next i

For n = 1 To ncov
newprem = Range(Range("PROJECTED_PREMIUMS").Cells.Offset(1, 0), Range("PROJECTED_PREMIUMS").Cells.End(xlDown)).Address
newpremAmt = Application.WorksheetFunction.Sum(Sheets("Data").Range(newprem))
oldprem = Range(Range("CURRENT_PREMIUMS").Cells.Offset(1, 0), Range("CURRENT_PREMIUMS").Cells.End(xlDown)).Address
oldpremAmt = Application.WorksheetFunction.Sum(Sheets("Data").Range(oldprem))
With myRng.Offset(0, n + 2).Cells(k)
On Error Resume Next
.Value = newpremAmt / oldpremAmt - 1
If Err.Number <> 0 Then
.Value = 0
End If
Err.Clear
.NumberFormat = "0.0%"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
On Error GoTo 0
Next n



newpremAmt = 0
oldpremAmt = 0
Next k

Call Rate_Filed
Application.StatusBar = False
Application.ScreenUpdating = True
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True


End Sub

 

[Andrzejek]

Hmmmm,
Your first For/Next loop shouldn't run at all;

...
Dim Lstrow As Integer
...
For i = 3 To Lstrow
  Application.StatusBar = "Row " & i & " of " & Lstrow & "- " & sFactor
  ...
Next i
...

there is no code to assign any value to [tt]Lstrow[/tt], or am I missing something?

Please use CODE TAGS, it is a lot easier to see your code and logic, plus some of your lines of code run together without the Tags :-(

Have fun.

---- Andy

A bus station is where a bus stops. A train station is where a train stops. On my desk, I have a work station.

 

[kjv1611]

I copied the most recent bit to Excel VBE to see what's going for basics... And yeah, if you'd use the code windows that' would help a ton. Also, I noticed that the first time you posted, you didn't post all of whatever code you were sharing, b/c you're missing a final End Sub.

Sub Rate_Filed is using recursive calls - calling itself. This can be a major performance impact, and create infinite loops if not used correctly. So that's something to consider in your process. For instance, why does it need to call itself? Sometimes that makes sense, but I know the times I've used that setup, the procedure would take in one variable when it is called. This procedure takes in no variables. One of the variables may be public, but from the code, I cannot see that.

So in the recursive pieces, I thought I'd build a separate procedure to call this one, and got to thinking... if it's calling itself multiple times, it's doing everything every time it's called. So if you pull all the stuff out that should just go before and after the full run to a separate procedure that calls this, then that itself should help. For instance, here's a quick test setup so far:

Sub CallRateFiled()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Call Rate_Filed
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = False [GREEN]' Do you need this at the end of the code?  Why is it used?[/GREEN]
    ThisWorkbook.Save
    Application.DisplayAlerts = True
    
End Sub

The line, ThisWorkbook.Save I would imagine would greatly slow things down in a recursive operation, particularly if the workbook is of any size.

And I realize you can't share the whole workbook, that should go without saying. However, if you were to create a sample/test version of it with fake data, that'd be helpful. Or if you could simply lay out the columns and a few rows of your starting data along with what you expect in the end, that might be of assistance.

I'll try to look a little more, to see what else I notice.

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[kjv1611]

Here's another question... where does Lge come from? It's used a short way down in the procedure.

Lge("A10").End(xlDown).Row

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[kjv1611]

sFactor - another Public variable perhaps? Not dimmed in the code, but shows up on this line:

        Application.StatusBar = "Row " & i & " of " & Lstrow & "- " & [b]sFactor[/b]

newprem and oldprem - same deal - not dimmed but used in code, so can only guess public variables


There's a Next k at the bottom of this procedure, but unless it got cropped in the copy/paste, there's no For k = 1 to whatever



"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[kjv1611]

hmmm... and now I just now notice that all this was in December...

Pyro777,

Are you still looking at this?

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[Pyro777]

Yes I am, I am sending all of your recommendations to my programmer, people in my company are pretty stubborn. Thank you everyone for your assistance. Let me know if you can think of anything else..