Excel 2013 Macros are running Extremely Slow.

[Pyro777]

My accounting team runs a Macro against a Workbook that takes approximately 35 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 (32 Bit), Office 2003 (4 Gig of Ram) Dual Core Processor. (Actual PC, not a Virtual)

New System:
Windows 7 (64 Bit), Office 2013 (8 Gig of Ram) (Citrix Virtual Desktop, 4 Processors (XEON) allocated)

Even with a Windows 7 32 Bit system running Office 2013 (Citrix Virtual Desktop), Macro still extremely Slow...
(Processors run at about 35 to 45 % when this macro is running so no over taxes processors) and Not much memory is being used while the macro is running)


Here is the Macro Coding they are using: (I cannot provide the workbook due to Company Policy)

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,

It would be better to post in forum707, where code questions are addressed.