VBA code running too slow in Excel 2013

[zk69]

Hi,

My Company moved to MS Office 2013 package, so my MS Excel 2010 was upgraded to version 2013.

Excel macro-enabled template - including VBA code - started to run dramatically slow in new version, if you compared it to the previous version (Excel 2010).

I tried every tricks I found on Internet, but none of them helped.

Private Sub ....
...

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

VBA code ...


Application.ScreenUpdating = True

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic
End Sub



My VBA code includes a lot of calling sub routines, but it ran much faster in Excel 2010.

I would very much appreciate if someone had an idea and would share with me

Regards
zk69
--------------------------------------------- The entire VBA code ---------------------------------------------


Private Sub Worksheet_Change(ByVal Target As Range)
Dim PipetteType As String
Dim PipetteVolumePiece As Integer
Dim PipetteRangeC As Range
Const Formula1_Valid = "=IF(AND(D38<E38; D39<E39; D40<E40; C34=1); ""VALID""; ""NOT VALID"")"
Const Formula2_Valid = "=IF(AND(D38<E38; D39<E39; D40<E40; C34=1; F38<G38; F39<G39; F40<G40; F34=1); ""VALID""; ""NOT VALID"")"
Const Formula3_Valid = "=IF(AND(D38<E38; D39<E39; D40<E40; C34=1; F38<G38; F39<G39; F40<G40; F34=1; H38<I38; H39<I39; H40<I40; I34=1); ""VALID""; ""NOT VALID"")"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
If Target.Address = "$G$5" Then
DoResetCell_SetWhiteColor ("E20:E20")
DoResetCell ("E21:E21")
DoResetCell_SetWhiteColor ("G20:G20")
DoResetCell ("G21:G21")
DoResetCell_SetWhiteColor ("I20:I20")
DoResetCell ("I21:I21")
DoResetCell_SetWhiteColor ("C24:C33")
DoResetCell_SetWhiteColor ("F24:F33")
DoResetCell_SetWhiteColor ("I24:I33")
DoResetCell ("C34")
DoResetCell ("F34")
DoResetCell ("I34")
DoSetWhiteFontColor ("D3640")
DoSetWhiteFontColor ("F36:F40")
DoSetWhiteFontColor ("H36:H40")
PipetteType = Range("G5").Value
Set PipetteRangeC = Sheet3.Range("A2:A54")
PipetteVolumePiece = WorksheetFunction.CountIf(PipetteRangeC, PipetteType)
' MsgBox "Pipetta típusa: " & PipetteType
' MsgBox "Pipetta méret szerinti darabszáma: " & PipetteVolumePiece
Select Case PipetteVolumePiece
Case 1
DoUnLock_SetColorCell ("E20:E20")
DoUnLockCell ("E21:E21")
Sheet1.Range("E21") = WorksheetFunction.Index(Sheet3.Range("A2:B55"), WorksheetFunction.Match(Sheet1.Range("G5"), Sheet3.Range("A2:A55"), 0), 2)
DoLockCell ("E21:E21")
DoLock_SetColorCell ("C24:C33")
DoSetFontColor ("D3640")
DoUnLockCell ("E42:E42")
Sheet1.Range("E42").FormulaLocal = Formula1_Valid
DoLockCell ("E42:E42")
Case 2
DoUnLock_SetColorCell ("E20:E20")
DoUnLockCell ("E21:E21")
DoUnLock_SetColorCell ("G20:G20")
DoUnLockCell ("G21:G21")
Sheet1.Range("G21") = WorksheetFunction.Index(Sheet3.Range("A2:B55"), WorksheetFunction.Match(Sheet1.Range("G5"), Sheet3.Range("A2:A55"), 0), 2)
Sheet1.Range("E21") = WorksheetFunction.Index(Sheet3.Range("A2:B55"), WorksheetFunction.Match(Sheet1.Range("G5"), Sheet3.Range("A2:A55"), 0) + 1, 2)
DoLockCell ("E21:E21")
DoLockCell ("G21:G21")
DoLock_SetColorCell ("C24:C33")
DoLock_SetColorCell ("F24:F33")
DoSetFontColor ("D3640")
DoSetFontColor ("F36:F40")
DoUnLockCell ("E42:E42")
Sheet1.Range("E42").FormulaLocal = Formula2_Valid
DoLockCell ("E42:E42")
Case 3
DoUnLock_SetColorCell ("E20:E20")
DoUnLockCell ("E21:E21")
DoUnLock_SetColorCell ("G20:G20")
DoUnLockCell ("G21:G21")
DoUnLock_SetColorCell ("I20:I20")
DoUnLockCell ("I21:I21")
Sheet1.Range("I21") = WorksheetFunction.Index(Sheet3.Range("A2:B55"), WorksheetFunction.Match(Sheet1.Range("G5"), Sheet3.Range("A2:A55"), 0), 2)
Sheet1.Range("G21") = WorksheetFunction.Index(Sheet3.Range("A2:B55"), WorksheetFunction.Match(Sheet1.Range("G5"), Sheet3.Range("A2:A55"), 0) + 1, 2)
Sheet1.Range("E21") = WorksheetFunction.Index(Sheet3.Range("A2:B55"), WorksheetFunction.Match(Sheet1.Range("G5"), Sheet3.Range("A2:A55"), 0) + 2, 2)
DoLockCell ("E21:E21")
DoLockCell ("G21:G21")
DoLockCell ("I21:I21")
DoLock_SetColorCell ("C24:C33")
DoLock_SetColorCell ("F24:F33")
DoLock_SetColorCell ("I24:I33")
DoSetFontColor ("D3640")
DoSetFontColor ("F36:F40")
DoSetFontColor ("H36:H40")
DoUnLockCell ("E42:E42")
Sheet1.Range("E42").FormulaLocal = Formula3_Valid
DoLockCell ("E42:E42")
End Select
End If




If Not IsEmpty(Sheet1.Range("E20")) And Not IsEmpty(Sheet1.Range("F12")) And Sheet1.Range("E20").Locked = False Then
DoUnLock_SetColorCell ("C24:C33")
ElseIf (IsEmpty(Sheet1.Range("E20")) Or IsEmpty(Sheet1.Range("F12"))) And Sheet1.Range("E20").Locked = False Then
DoLock_SetColorCell ("C24:C33")
End If


If Not IsEmpty(Sheet1.Range("G20")) And Not IsEmpty(Sheet1.Range("F12")) And Sheet1.Range("G20").Locked = False Then
DoUnLock_SetColorCell ("F24:F33")
ElseIf (IsEmpty(Sheet1.Range("G20")) Or IsEmpty(Sheet1.Range("F12"))) And Sheet1.Range("G20").Locked = False Then
DoLock_SetColorCell ("F24:F33")
End If


If Not IsEmpty(Sheet1.Range("I20")) And Not IsEmpty(Sheet1.Range("F12")) And Sheet1.Range("I20").Locked = False Then
DoUnLock_SetColorCell ("I24:I33")
ElseIf (IsEmpty(Sheet1.Range("I20")) Or IsEmpty(Sheet1.Range("F12"))) And Sheet1.Range("I20").Locked = False Then
DoLock_SetColorCell ("I24:I33")
End If




If Not IsEmpty(Sheet1.Range("E20")) And Not Intersect(Target, Range("C24:C33")) Is Nothing Then
Call CompareToBalance(1, "C24:C33")
End If


If Not IsEmpty(Sheet1.Range("G20")) And Not Intersect(Target, Range("F24:F33")) Is Nothing Then
Call CompareToBalance(2, "F24:F33")
End If


If Not IsEmpty(Sheet1.Range("I20")) And Not Intersect(Target, Range("I24:I33")) Is Nothing Then
Call CompareToBalance(3, "I24:I33")
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub




Private Sub FoundEmptyCells(ThisRange)
If WorksheetFunction.CountA(Range(ThisRange)) < 10 Then
MsgBox "The " & ThisRange & " cell range contains empty cell(s)!"
End If
End Sub








Private Sub CompareToBalance(ByVal PVP As Integer, ThisRange)
Dim Cell_M As Range
Dim WorkRange_M As Range
Dim Counter_M As Integer
Dim Counter_Loop As Integer
Set WorkRange_M = Sheet1.Range(ThisRange)
Counter_M = 0
Counter_Loop = 0
For Each Cell_M In WorkRange_M
Counter_Loop = Counter_Loop + 1
If Cell_M <> "" And Cell_M < Sheet1.Range("F12").Value Then
Counter_M = Counter_M + 1
MsgBox "Kisebb mért értéket adott meg a " & Cell_M.Address & " cellában, mint a használt mérleg minimum tömege!"
Sheet1.Range(Cell_M.Address).Select
Sheet1.Range(Cell_M.Address).Activate
If PVP = 1 Then
DoUnLockCell ("C34")
Sheet1.Range("C34").Value = 0
DoLockCell ("C34")
ElseIf PVP = 2 Then
DoUnLockCell ("F34")
Sheet1.Range("F34").Value = 0
DoLockCell ("F34")
ElseIf PVP = 3 Then
DoUnLockCell ("I34")
Sheet1.Range("I34").Value = 0
DoLockCell ("I34")
End If
Exit Sub
ElseIf Cell_M = "" Then
Counter_M = Counter_M + 1
' MsgBox "Adjon meg értéket a " & Cell_M.Address & " cellában!"
Sheet1.Range(Cell_M.Address).Select
Sheet1.Range(Cell_M.Address).Activate
If PVP = 1 Then
DoUnLockCell ("C34")
Sheet1.Range("C34").Value = 0
DoLockCell ("C34")
ElseIf PVP = 2 Then
DoUnLockCell ("F34")
Sheet1.Range("F34").Value = 0
DoLockCell ("F34")
ElseIf PVP = 3 Then
DoUnLockCell ("I34")
Sheet1.Range("I34").Value = 0
DoLockCell ("I34")
End If
Exit Sub
Else
If PVP = 1 And Counter_M = 0 And Cell_M <> "" Then
DoUnLockCell ("C34")
Sheet1.Range("C34").Value = 1
DoLockCell ("C34")
ElseIf PVP = 2 And Counter_M = 0 And Cell_M <> "" Then
DoUnLockCell ("F34")
Sheet1.Range("F34").Value = 1
DoLockCell ("F34")
ElseIf PVP = 3 And Counter_M = 0 And Cell_M <> "" Then
DoUnLockCell ("I34")
Sheet1.Range("I34").Value = 1
DoLockCell ("I34")
End If
End If
Next Cell_M
End Sub




Private Sub DoUnLockCell(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).Locked = False
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoUnLock_SetColorCell(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).Locked = False
Worksheets("Sheet1").Range(ThisRange).Interior.Color = RGB(255, 204, 0)
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoSetWhiteFontColor(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).Locked = False
Worksheets("Sheet1").Range(ThisRange).Font.Color = RGB(255, 255, 255)
Worksheets("Sheet1").Range(ThisRange).Locked = True
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoSetFontColor(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).Locked = False
Worksheets("Sheet1").Range(ThisRange).Font.Color = RGB(0, 0, 0)
Worksheets("Sheet1").Range(ThisRange).Locked = True
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoResetCell(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).ClearContents
Worksheets("Sheet1").Range(ThisRange).Locked = True
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoClearContents(ThisRange)
Worksheets("Sheet1").Range(ThisRange).ClearContents
End Sub




Private Sub DoResetCell_SetWhiteColor(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).ClearContents
Worksheets("Sheet1").Range(ThisRange).Interior.Color = RGB(255, 255, 255)
Worksheets("Sheet1").Range(ThisRange).Locked = True
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoLockCell(ThisRange) 'Zárolja a cellákat!
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).Locked = True
ActiveSheet.Protect Password:="*********xx"
End Sub




Private Sub DoLock_SetColorCell(ThisRange)
ActiveSheet.Unprotect Password:="*********xx"
Worksheets("Sheet1").Range(ThisRange).Locked = False
Worksheets("Sheet1").Range(ThisRange).Interior.Color = RGB(255, 204, 0)
Worksheets("Sheet1").Range(ThisRange).Locked = True
ActiveSheet.Protect Password:="*********xx"
End Sub

[mdmackillop]

Can you post some sample data to determine where the issues are?

[zk69]

Can you post some sample data to determine where the issues are?

Hi.

I enclosed an attachment.
When you select item from drop-down list (G5 cell), it takes more than 20 seconds until all related cells are set up.
Too many protect sheet - unprotect sheets calling?

Thanks.

Regards
zk69

See "
Private Sub Worksheet_Change(ByVal Target As Range)

...

If Target.Address = "$G$5" Then
...

[p45cal]

Too many protect sheet - unprotect sheets calling?Perhaps. On opening the workbook you could use .Protect with the UserInterfaceOnly set to True, that stays in force until the workbook is closed, or until another .Protect instruction that doesn't include it is executed. It would mean your code never has to unprotect to allow vba to do something.
Another thing that sometimes slows down vba is being connected to a printer, especially if the page setup is being changed. There's an Application.PrintCommunication property that you can set to False, then reset to True after processing has finished. It might be worth a try.
Something else, the WorkSheet_Change event code, does its code change things in the same worksheet? Is it calling itself more often than it would in Excel 2010 (I don't have Excel 2013)? If so perhaps an Application.EnableEvents=False bfore the code and Application.EnableEvents=True after might help.

[zk69]

Hi p45cal

Thank you very much for your help.
Your suggestion is perfect!

I appreciate your help and you sharing your experience.

Regards
zk69

[p45cal]

Your suggestion is perfect

Which one gave the greatest increase in speed?

[mdmackillop]

Maybe much more marginal but pass ranges and use With
e.g.

If Target.Address = "$G$5" Then
DoResetCell_SetWhiteColor Range("E20:E20")
DoResetCell Range("E21:E21")


Private Sub DoResetCell(ThisRange)
With ThisRange
.ClearContents
.Locked = True
End With
End Sub



Private Sub DoResetCell_SetWhiteColor(ThisRange)
With ThisRange
.ClearContents
.Interior.Color = RGB(255, 255, 255)
.Locked = True
End With
End Sub

[zk69]

Apply .Protect with the UserInterfaceOnly. solved the performance problem.

Thanks a lot.

[snb]

May I suggest to dive into 'conditional formattting' ?

PS. Like p45cal showed: 'protection' does more harm than it prevents.

[p45cal]

Apply .Protect with the UserInterfaceOnly solved the performance problem.Now THAT is not what I expected! Another one to put in the memory banks.

[zk69]

But the lead time drastically decreased when I killed ActiveSheet.Unprotect and ActiveSheet.ProtectProtect commands and started to use "Sheets("Sheet1").Protect Password:=strPASSWARD, UserInterFaceOnly:=True"

First it run into error message (Compile error in hidden module ...).
I had to declare a variable.
Const strPASSWARD As String = "************"

When you selected item from drop-down list (G5 cell), it took more than 20 seconds until all related cells were set up.
But now it takes not more than 1 second.

Regards
zk69

[zk69]

Hi snb

I usually use 'conditional formattting', but if you have any idea, please share with me.
p45cal's suggestion works and provide a solution for performance problem.

Regards
zk69

[snb]

I usually use 'conditional formattting',

Then why so many formatting code in VBA ?

[Aflatoon]

The protection algorithm in later versions of Excel is more secure but also a lot slower, so repeated calls to unprotect and reprotect will slow down the code a lot.