zk69
08-15-2017, 06:21 AM
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
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