(Solved) – VBA code in excel runs slow on Activate event in worksheet. Need to improve performance please

  • by
(solved)-–-vba-code-in-excel-runs-slow-on-activate-event-in-worksheet.-need-to-improve-performance-please

I am trying to protect rows, set dropdown list dynamically on Worksheet_Activate event but my code for 1000 rows takes 15 mins to open the worksheet as it keeps spinning. When I switch between tabs I want to be able to set the dropdowns, disable rows and set color on the rows.Can you tell how I can improve the performance of the worksheet while being able to achieve the mentioned objective.?

Option Explicit

Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean

Sub OptimizeCode_Begin()

Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

End Sub

Sub OptimizeCode_End()

ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True

End Sub




Private Sub Worksheet_Activate()
On Error Resume Next


'Optimize Code
  Call OptimizeCode_Begin


 Call DisableOsIs 'ARS

'Optimize Code
  Call OptimizeCode_End

End Sub


Sub DisableOsIs()

On Error Resume Next

Dim NoOfDataRows As Integer
Dim RngOP, RngIL, RngL, RngM, RngN, RngO, RngP, RngQ, RngR, RngLockAll As Range
Dim cell As Range
'ActiveSheet.Unprotect Password:="1234"
'Set NoOfDataRows = ActiveSheet.UsedRange.Rows.Count
Set RngOP = Range("P5:P" & ActiveSheet.UsedRange.Rows.Count)
Set RngIL = Range("I5:I" & ActiveSheet.UsedRange.Rows.Count)
Set RngL = Range("L5:L" & ActiveSheet.UsedRange.Rows.Count)
Set RngM = Range("M5:M" & ActiveSheet.UsedRange.Rows.Count)
Set RngN = Range("N5:N" & ActiveSheet.UsedRange.Rows.Count)
Set RngO = Range("O5:O" & ActiveSheet.UsedRange.Rows.Count)
Set RngP = Range("P5:P" & ActiveSheet.UsedRange.Rows.Count)
Set RngQ = Range("Q5:Q" & ActiveSheet.UsedRange.Rows.Count)
Set RngR = Range("R5:R" & ActiveSheet.UsedRange.Rows.Count)
'Set RngLockAll = Range("A" & ActiveSheet.UsedRange.Rows.Count   1 & ":R" & ActiveSheet.UsedRange.Rows.Count   1000)

For Each cell In RngL
 Call SetLEDWattageList(cell)
Next cell
For Each cell In RngM
 Call SetCTempList(cell)
Next cell
For Each cell In RngN
 Call SetLShield(cell)
Next cell
For Each cell In RngO
 Call SetRemoveSLModifyAList(cell)
Next cell
For Each cell In RngP
 Call SetRemoveSLModifyAList(cell)
Next cell
For Each cell In RngQ
 Call SetALengthList(cell)
Next cell
For Each cell In RngR
 Call SetArmDModList(cell)
Next cell

For Each cell In RngOP

    If cell.Value = "Yes" Then
       Call ChangeCode(cell)
    ElseIf cell.Value = "No" Then
      Call ChangeCode(cell)
    End If

Next cell

For Each cell In RngIL

   If cell.Value = "DEL" Then
      Call DisableDEL(cell)
   End If

Next cell

Call LockAll

End Sub

'Lock 1000 rows after the last row entered in the worksheet
Sub LockAll()

On Error Resume Next

Dim NoOfDataRows As Integer
Dim RngO, RngI As Range
Dim cell As Range
ActiveSheet.Unprotect Password:="1234"
'Set NoOfDataRows = ActiveSheet.UsedRange.Rows.Count
Set RngI = Range("A" & ActiveSheet.UsedRange.Rows.Count   1 & ":R" & ActiveSheet.UsedRange.Rows.Count   1000)

For Each cell In RngI
 cell.Locked = True
Next cell

ActiveSheet.Protect Password:="1234"

End Sub

Sub SetLEDWattageList(ByVal Target As Range)

 With Cells(Target.Row, Target.Column)
       .Locked = False
        With .Validation
            .Delete
            'replace "=A1:A6" with the range the data is in.
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!D2:D5"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
 End With

End Sub

Sub SetCTempList(ByVal Target As Range)

 With Cells(Target.Row, Target.Column)
        .Locked = False
        With .Validation
            .Delete
            'replace "=A1:A6" with the range the data is in.
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!E2:E3"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
 End With

End Sub

Sub SetLShield(ByVal Target As Range)

 With Cells(Target.Row, Target.Column)
        .Locked = False
        With .Validation
            .Delete
            'replace "=A1:A6" with the range the data is in.
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!A2:A4"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
 End With

End Sub

Sub SetRemoveSLModifyAList(ByVal Target As Range)

 With Cells(Target.Row, Target.Column)
        .Locked = False
        With .Validation
            .Delete
            'replace "=A1:A6" with the range the data is in.
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!I2:I3"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
 End With

End Sub

Sub SetALengthList(ByVal Target As Range)

 With Cells(Target.Row, Target.Column)
        .Locked = False
        With .Validation
            .Delete
            'replace "=A1:A6" with the range the data is in.
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!F2:F4"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
 End With

End Sub
Sub SetArmDModList(ByVal Target As Range)

 With Cells(Target.Row, Target.Column)
        .Locked = False
        With .Validation
            .Delete
            'replace "=A1:A6" with the range the data is in.
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!G2:G9"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
 End With

End Sub


Sub DisableIs()

On Error Resume Next

Dim NoOfDataRows As Integer
Dim RngO, RngI As Range
Dim cell As Range
ActiveSheet.Unprotect Password:="1234"
'Set NoOfDataRows = ActiveSheet.UsedRange.Rows.Count
Set RngI = Range("I5:I" & ActiveSheet.UsedRange.Rows.Count)

For Each cell In RngI

   If cell.Value = "DEL" Then
      Call DisableDEL(cell)
   End If

Next cell

ActiveSheet.Protect Password:="1234"

End Sub



Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
'Application.EnableEvents = False
'MsgBox "change"
'ActiveSheet.Unprotect Password:="1234"
    Call ChangeCode(Target)
    Call DisableDEL(Target)
    Call DisableIs
'ActiveSheet.Protect Password:="1234"
'Application.EnableEvents = True

End Sub


Sub ChangeCode(ByVal Target As Range)
On Error Resume Next

 'Check if Target cell in the "Make a selection" range is changed
    If Not Intersect(Target, Range("P5:P" & ActiveSheet.UsedRange.Rows.Count)) Is Nothing Then
'    ActiveSheet.Cells.Locked = False
        If Target.Value = "Yes" Then
         ActiveSheet.Unprotect Password:="1234" 'ARS
            'Dropdown and error message on cells 2 and 3 columns left of "Make a selection" will be enabled
'            With Cells(Target.Row, Target.Column   2).Validation
'                .InCellDropdown = True
'                .ShowError = True
'            End With
'            With Cells(Target.Row, Target.Column   3).Validation
'                .InCellDropdown = True
'                .ShowError = True
'            End With

            With Cells(Target.Row, Target.Column   1)
'                   .Interior.Color = RGB(221, 217, 196)
                   .Interior.Color = RGB(255, 255, 255)
                With .Validation
                .InCellDropdown = True
                .ShowError = True
                End With

            End With

              With Cells(Target.Row, Target.Column   2)
'                   .Interior.Color = RGB(221, 217, 196)
                   .Interior.Color = RGB(255, 255, 255)
                With .Validation
                .InCellDropdown = True
                .ShowError = True
                End With

            End With

            'Target.Locked = False

'            ActiveSheet.Unprotect Password:="1234"
            Target.Locked = False
            'Range(Target.Row & ":" & Target.Column).Cells.Locked = False
            Cells(Target.Row, Target.Column   1).Locked = False
            Cells(Target.Row, Target.Column   2).Locked = False
           ActiveSheet.Protect Password:="1234"  'Contents:=True, DrawingObjects:=False  'ARS

        ElseIf Target.Value = "No" Then

            ActiveSheet.Unprotect Password:="1234" 'ARS
            'Dropdown and error message on cells 2 and 3 columns left of "Make a selection" will be enabled
'             With Cells(Target.Row, Target.Column   2).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With
'            With Cells(Target.Row, Target.Column   3).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

            With Cells(Target.Row, Target.Column   1)
                   '.Interior.Color = RGB(200, 200, 200)
                   .Interior.Color = RGB(221, 217, 196)
                   .Value = vbNullString
                With .Validation
                .InCellDropdown = False
                .ShowError = False
                End With

            End With

             With Cells(Target.Row, Target.Column   2)
                   '.Interior.Color = RGB(200, 200, 200)
                   .Interior.Color = RGB(221, 217, 196)
                   .Value = vbNullString
                With .Validation
                .InCellDropdown = False
                .ShowError = False
                End With

            End With


             Target.Locked = False
             Cells(Target.Row, Target.Column   1).Locked = True
             Cells(Target.Row, Target.Column   2).Locked = True
'            Cells(Target.Row, Target.Column   2).Locked = True
'            Cells(Target.Row, Target.Column   3).Locked = True
'            ActiveSheet.Protect Contents:=True, DrawingObjects:=False
             ActiveSheet.Protect Password:="1234"  'Contents:=True, DrawingObjects:=False  'ARS

        End If
    End If

End Sub


Sub DisableDEL(ByVal Target As Range)
 On Error Resume Next

' If (Target.Address = "$O$5") Then
'    'Target.Range("O5:08").ClearContents = True
'    Target.Range("Q5:Q8").Validation.Delete


'    With Target.Validation
'     .Delete
'
'    End With
' End If

 'MsgBox ActiveSheet.UsedRange.Rows.Count
 'ActiveSheet.Cells.Locked = False

'ActiveSheet.Unprotect Password:="1234"

 'Check if Target cell in the "Make a selection" range is changed
    If Not Intersect(Target, Range("I5:O" & ActiveSheet.UsedRange.Rows.Count)) Is Nothing Then
'    ActiveSheet.Cells.Locked = False
        If Target.Value = "DEL" Then
         ActiveSheet.Unprotect Password:="1234" 'ARS
            'Dropdown and error message on cells 2 and 3 columns left of "Make a selection" will be enabled
            With Cells(Target.Row, Target.Column   1)
                 .Interior.Color = RGB(255, 255, 204)
                 '.Value = vbNullString
            End With
            With Cells(Target.Row, Target.Column   2)
                 .Interior.Color = RGB(255, 255, 204)
                 '.Value = vbNullString
            End With
            With Cells(Target.Row, Target.Column   3)
                 .Interior.Color = RGB(217, 217, 217)
                 .Value = vbNullString

                With .Validation
                .InCellDropdown = False
                .ShowError = False
                End With

            End With

'           With Cells(Target.Row, Target.Column   3).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With
           With Cells(Target.Row, Target.Column   4)
                 .Interior.Color = RGB(217, 217, 217)
                 .Value = vbNullString

              With .Validation
                .InCellDropdown = False
                .ShowError = False
              End With

           End With

'            With Cells(Target.Row, Target.Column   4).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

           With Cells(Target.Row, Target.Column   5)
                 .Interior.Color = RGB(217, 217, 217)
                 .Value = vbNullString
               With .Validation
                .InCellDropdown = False
                .ShowError = False
               End With

           End With
'             With Cells(Target.Row, Target.Column   5).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

             With Cells(Target.Row, Target.Column   6)
                 .Interior.Color = RGB(217, 217, 217)
                 .Value = vbNullString

               With .Validation
                  .InCellDropdown = False
                  .ShowError = False
                End With

            End With
'            With Cells(Target.Row, Target.Column   6).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

             With Cells(Target.Row, Target.Column   7)
                 .Interior.Color = RGB(217, 217, 217)
                 .Value = vbNullString

                    With .Validation
                .InCellDropdown = False
                .ShowError = False
                End With

            End With
'             With Cells(Target.Row, Target.Column   7).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

             With Cells(Target.Row, Target.Column   8)
                 .Interior.Color = RGB(221, 217, 196)
                 .Value = vbNullString

                    With .Validation
                .InCellDropdown = False
                .ShowError = False
                End With

            End With
'              With Cells(Target.Row, Target.Column   8).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

              With Cells(Target.Row, Target.Column   9)
                 .Interior.Color = RGB(221, 217, 196)
                 .Value = vbNullString

                    With .Validation
                .InCellDropdown = False
                .ShowError = False
                End With

            End With
'              With Cells(Target.Row, Target.Column   9).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With


            'Target.Locked = False

'            ActiveSheet.Unprotect Password:="1234"
            Target.Locked = False
            'Range(Target.Row & ":" & Target.Column).Cells.Locked = False
            Cells(Target.Row, Target.Column   1).Locked = True
            Cells(Target.Row, Target.Column   2).Locked = True
            Cells(Target.Row, Target.Column   3).Locked = True
            Cells(Target.Row, Target.Column   4).Locked = True
            Cells(Target.Row, Target.Column   5).Locked = True
            Cells(Target.Row, Target.Column   6).Locked = True
            Cells(Target.Row, Target.Column   7).Locked = True
            Cells(Target.Row, Target.Column   8).Locked = True
            Cells(Target.Row, Target.Column   9).Locked = True
            ActiveSheet.Protect Password:="1234"  'Contents:=True, DrawingObjects:=False 'ARS

        End If
    End If

End Sub


Sub HighlightHPS(ByVal Target As Range)
 On Error Resume Next

' If (Target.Address = "$O$5") Then
'    'Target.Range("O5:08").ClearContents = True
'    Target.Range("Q5:Q8").Validation.Delete


'    With Target.Validation
'     .Delete
'
'    End With
' End If

 'MsgBox ActiveSheet.UsedRange.Rows.Count
 'ActiveSheet.Cells.Locked = False

'ActiveSheet.Unprotect Password:="1234"

 'Check if Target cell in the "Make a selection" range is changed
    If Not Intersect(Target, Range("I5:O" & ActiveSheet.UsedRange.Rows.Count)) Is Nothing Then
'    ActiveSheet.Cells.Locked = False
        If Target.Value = "HPS" Then
         ActiveSheet.Unprotect Password:="1234" 'ARS
            'Dropdown and error message on cells 2 and 3 columns left of "Make a selection" will be enabled
            With Cells(Target.Row, Target.Column   1)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(255, 255, 204)
                 '.Value = vbNullString
            End With
            With Cells(Target.Row, Target.Column   2)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(255, 255, 204)
                 '.Value = vbNullString
            End With
            With Cells(Target.Row, Target.Column   3)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(217, 217, 217)
                 .Value = vbNullString

'                With .Validation
'                .InCellDropdown = False
'                .ShowError = False
'                End With

            End With

'           With Cells(Target.Row, Target.Column   3).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With
           With Cells(Target.Row, Target.Column   4)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(217, 217, 217)
                 .Value = vbNullString

'              With .Validation
'                .InCellDropdown = False
'                .ShowError = False
'              End With

           End With

'            With Cells(Target.Row, Target.Column   4).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

           With Cells(Target.Row, Target.Column   5)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(217, 217, 217)
                 .Value = vbNullString
'               With .Validation
'                .InCellDropdown = False
'                .ShowError = False
'               End With

           End With
'             With Cells(Target.Row, Target.Column   5).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

             With Cells(Target.Row, Target.Column   6)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(217, 217, 217)
                 .Value = vbNullString

'               With .Validation
'                  .InCellDropdown = False
'                  .ShowError = False
'                End With

            End With
'            With Cells(Target.Row, Target.Column   6).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

             With Cells(Target.Row, Target.Column   7)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(217, 217, 217)
                 .Value = vbNullString

'                    With .Validation
'                .InCellDropdown = False
'                .ShowError = False
'                End With

            End With
'             With Cells(Target.Row, Target.Column   7).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

             With Cells(Target.Row, Target.Column   8)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(221, 217, 196)
                 .Value = vbNullString

'                    With .Validation
'                .InCellDropdown = False
'                .ShowError = False
'                End With

            End With
'              With Cells(Target.Row, Target.Column   8).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With

              With Cells(Target.Row, Target.Column   10)
                 .Interior.Color = RGB(255, 0, 0) 'RGB(221, 217, 196)
                 .Value = vbNullString

'                    With .Validation
'                .InCellDropdown = False
'                .ShowError = False
'                End With

            End With
'              With Cells(Target.Row, Target.Column   9).Validation
'                .InCellDropdown = False
'                .ShowError = False
'            End With


            'Target.Locked = False

'            ActiveSheet.Unprotect Password:="1234"
            'Target.Locked = False
            'Range(Target.Row & ":" & Target.Column).Cells.Locked = False
'            Cells(Target.Row, Target.Column   1).Locked = True
'            Cells(Target.Row, Target.Column   2).Locked = True
'            Cells(Target.Row, Target.Column   3).Locked = True
'            Cells(Target.Row, Target.Column   4).Locked = True
'            Cells(Target.Row, Target.Column   5).Locked = True
'            Cells(Target.Row, Target.Column   6).Locked = True
'            Cells(Target.Row, Target.Column   7).Locked = True
'            Cells(Target.Row, Target.Column   8).Locked = True
'            Cells(Target.Row, Target.Column   9).Locked = True
            ActiveSheet.Protect Password:="1234"  'Contents:=True, DrawingObjects:=False 'ARS

        End If
    End If

End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *