excel - Excel 中的 VBA 代码在工作表中的激活事件上运行缓慢。需要提高性能请

Question

我正在尝试保护行，在 Worksheet_Activate 事件上动态设置下拉列表，但我的 1000 行代码需要 15 分钟才能打开工作表，因为它一直在旋转。当我在选项卡之间切换时，我希望能够设置下拉列表、禁用行并在行上设置颜色。你能告诉我如何在实现上述目标的同时提高工作表的性能吗？

     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)


        Call SetLEDWattageList(RngL) 
        Call SetColorTemperatureList(RngM) 
        Call SetLShield(RngN) 
        Call SetRemoveSLModifyAList(RngO) 
        Call SetRemoveSLModifyAList(RngP) 
        Call SetALengthList(RngQ) 
        Call SetArmDModList(RngR)
        Call DisableLED(RngIL)  
        Call LockAll(RngLockAll)



        End Sub


    Sub LockAll(ByVal Target As Range)

    On Error Resume Next

    ActiveSheet.Unprotect Password:="1234"

    With Cells(Target.Row, Target.Column)
           .Locked = True
     End With

    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 SetColorTemperatureList(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

'I am passing in a range and checking if the value is LED and color the 'successive columns and protect them.
Sub DisableLED(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("I5:O" & ActiveSheet.UsedRange.Rows.Count)) Is Nothing Then
'    ActiveSheet.Cells.Locked = False
        If Target.Value = "LED" Then
         ActiveSheet.Unprotect Password:="1234" 
            '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 + 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 + 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 + 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 + 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 + 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 + 9)
                 .Interior.Color = RGB(221, 217, 196)
                 .Value = vbNullString

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

            End With


            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 

        End If
    End If

End Sub

标签： excelvba

Answer 1

乍一看，您的代码不需要您调用的函数会浪费时间逐个单元格地调用它们。例如，可以替换前三个调用，从而使代码更高效，只需执行以下操作：

 Dim RngIL As Range, RngM As Range, RngN As Range, lastRow As Long
 Dim sh As Worksheet
 Set sh = ActiveSheet 'You have to define sh according to your sheet name
 sh.Unprotect "1234"
 lastRow = sh.Cells(sh.Rows.count, "M").End(xlUp).Row

  Set RngIL = sh.Range("I5:I" & lastRow): RngIL.Locked = False
   With RngIL.Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!D$2:D$5"
    .IgnoreBlank = True
    .InCellDropdown = True
    .ShowInput = True
    .ShowError = True
  End With

  Set RngM = sh.Range("M5:M" & lastRow): RngM.Locked = False
   With RngM.Validation
      .Delete
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!E$2:E$3"
      .IgnoreBlank = True
      .InCellDropdown = True
      .InputTitle = ""
      .ShowInput = True
      .ShowError = True
   End With

   Set RngN = sh.Range("N5:N" & lastRow): RngN.Locked = False
    With RngM.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:="=listone!A$2:A$4"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With

    'do here the locking procedure if you consider it makes sense...
    sh.Protect "1234"

    'and so on for all ranges where you must change their cells in the same way...

还有一段更简单/更短的代码做同样的事情，但不保护工作表：

Sub testSimplified()
 Dim RngIL As Range, RngM As Range, RngN As Range, lastRow As Long, cel As Range
 Dim sh As Worksheet
 Set sh = ActiveSheet 'You have to define sh according to your sheet name
 sh.Unprotect "1234"
 lastRow = sh.Cells(sh.Rows.count, "M").End(xlUp).Row
  Set RngIL = sh.Range("I5:I" & lastRow): RngIL.Locked = False
    ChangeValidation RngIL, "=listone!D$2:D$5"

  Set RngM = sh.Range("M5:M" & lastRow): RngM.Locked = False
    ChangeValidation RngM, "=listone!E$2:E$3"

   Set RngN = sh.Range("N5:N" & lastRow): RngN.Locked = False
     ChangeValidation RngN, "=listone!A$2:A$4"

   'do here the locking procedure...
   For Each cel In RngIL
        If cel.value = "LED" Then
            DisableLED cel, sh
        End If
   Next
   sh.Protect "1234"
End Sub
Sub ChangeValidation(rng As Range, strCondition As String)
    With rng.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
            Operator:=xlBetween, Formula1:=strCondition
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
End Sub
Sub DisableLED(ByVal Target As Range, sh As Worksheet)
    With sh.Range(Target.Offset(0, 1).Address & ":" & Target.Offset(0, 2).Address)
            .Interior.Color = RGB(255, 255, 204)
    End With
    With sh.Range(Target.Offset(0, 3).Address & ":" & Target.Offset(0, 7).Address)
        .Interior.Color = RGB(217, 217, 217)
        .Validation.Delete
    End With
    With sh.Range(Target.Offset(0, 8).Address & ":" & Target.Offset(0, 9).Address)
        .Interior.Color = RGB(221, 217, 196)
        .Validation.Delete
    End With
    sh.Range(Target.Offset(0, 1).Address & ":" & Target.Offset(0, 9).Address).Locked = True
End Sub

您必须注意使验证范围是绝对的（在验证范围行前面使用“$”）...更好的方法是使用命名范围。由于工作表在代码开头已不受保护，因此无需在被调用的子程序中取消保护。