根据单元格值

Question

我尝试编写宏，其中根据单元格值隐藏行（这是一个数据验证下拉列表）：

使用以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target = Range("C15") Then

        BeginRow = 17
        EndRow = 25
        ChkCol = 4

        For RowCnt = BeginRow To EndRow
            If Cells(RowCnt, ChkCol).Value = Cells(15, 3).Value Then
                Cells(RowCnt, ChkCol).EntireRow.Hidden = False
            Else
                Cells(RowCnt, ChkCol).EntireRow.Hidden = True
            End If
        Next RowCnt
    End If
exitHandler:
  Application.EnableEvents = True

End Sub

它正在做我需要的事情，但我面临的问题是，C15的任何变化需要时间（实际数据大约有100行），而且当我试图制作任何在工作表的其余部分更改，它会引发错误 -

  

＆＃34;运行时错误＆＃39; 13＆＃39;：类型不匹配＆＃34;。

我没有宏经验，而且我不确定我做错了什么。你能帮我纠正一下代码吗？如果有更好的方法以更有效的方式完成相同的任务，请告诉我。

Answer 1

通过几百（甚至几千）行循环检查隐藏属性将运行得足够快。关键点是将检查限制为仅限于所需的单元格，并在一次操作中执行隐藏/取消隐藏（如果一次执行一行，则为慢速位）

使用逻辑：

• 如果单元格C15发生变化，请检查整个列表或
• 如果列表D17:D25（或更大）中的一个或多个单元格更改，则仅更改单元格
• 构建对必须更改隐藏状态的行的引用，并为整个范围设置隐藏属性

此代码几乎立即在几千行的列表范围内运行

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim cl As Range
    Dim rTest As Range, vTest As Variant
    Dim rList As Range
    Dim rHide As Range, rUnhide As Range

    On Error GoTo EH

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set rTest = Me.Cells(15, 3) ' Cell to compare to
    Set rList = Me.Range("D17:D25") ' List of cells to compare to the Test cell

    If Not Application.Intersect(Target, rTest) Is Nothing Then
        ' Test cell has changed, so process whole list
        Set rng = rList
    Else
        ' Only process changed cells in the list
        Set rng = Application.Intersect(Target, rList)
    End If

    If Not rng Is Nothing Then
        ' there is somthing to process
        vTest = rTest.Value
        For Each cl In rng.Cells
            If cl.EntireRow.Hidden Then
                ' the row is already hidden
                If cl.Value = vTest Then
                    ' and it should be visible, add it to the Unhide range
                    If rUnhide Is Nothing Then
                        Set rUnhide = cl
                    Else
                        Set rUnhide = Application.Union(rUnhide, cl)
                    End If
                End If
            Else
                ' the row is already visible
                If cl.Value <> vTest Then
                    ' and it should be hidden, add it to the Hide range
                    If rHide Is Nothing Then
                        Set rHide = cl
                    Else
                        Set rHide = Application.Union(rHide, cl)
                    End If
                End If
            End If
        Next

        ' do the actual hiding/unhiding in one go (faster)
        If Not rUnhide Is Nothing Then
            rUnhide.EntireRow.Hidden = False
        End If
        If Not rHide Is Nothing Then
            rHide.EntireRow.Hidden = True
        End If

    End If

EH:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Answer 2

您可以快速使用Autofilter。

您可以轻松更改BeginRow，EndRow和ChkCol以调整范围，代码仍可正常工作。

如果您只想显示与所选项目不同的内容，请设为Criteria1:="<>" & Target。

10000行的

0.008秒。

代码：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim BeginRow As Long
    Dim EndRow As Long
    Dim ChkCol As Long
    Dim RowCnt As Long

    With ActiveSheet

        If Target.Address = Range("C15").Address Then

            BeginRow = 17
            EndRow = 25
            ChkCol = 4

            Dim filterRange As Range

            Set filterRange = .Range(.Cells(BeginRow - 1, ChkCol - 1), .Cells(EndRow, ChkCol))

            filterRange.AutoFilter

            filterRange.AutoFilter Field:=1, Criteria1:= Target 

        End If

    End With

End Sub

Answer 3

为了防止错误，您需要使用错误处理程序。如果您选择多个单元格并尝试删除它们，则会发生错误

    Option Explicit

    Private Sub Worksheet_Change(ByVal Target As Range)

    Const BeginRow = 17
    Const EndRow = 25
    Const ChkCol = 4

    Dim RowCnt As Long

        On Error GoTo exitHandler

        Application.EnableEvents = False


        If Target = Range("C15") Then

            For RowCnt = BeginRow To EndRow
                If Cells(RowCnt, ChkCol).Value = Cells(15, 3).Value Then
                    Cells(RowCnt, ChkCol).EntireRow.Hidden = False
                Else
                    Cells(RowCnt, ChkCol).EntireRow.Hidden = True
                End If
            Next RowCnt
        End If

exitHandler:
        Application.EnableEvents = True

    End Sub

编辑基于QHarr的想法，使用自动过滤器

Private Sub Worksheet_Change(ByVal Target As Range)
Const BeginRow = 17
Const EndRow = 25
Const ChkCol = 4
Dim RowCnt As Long


    On Error GoTo EH

    'If you want to prevent error 13 you could uncomment the following line
    'If Target.Cells.CountLarge > 1 Then Exit Sub

    Application.EnableEvents = False

    If Target = Range("C15") Then

        Dim filterRange As Range
        Set filterRange = Range(Cells(BeginRow - 1, ChkCol), Cells(EndRow, ChkCol))
        filterRange.AutoFilter
        filterRange.AutoFilter Field:=1, Criteria1:=Target

    End If

EH:
    Application.EnableEvents = True

End Sub

EDIT2 运行时错误13的原因是行Target = Range（＆＃34; C15＆＃34;）。如果您选择多个单元格，则将范围与值进行比较，因为范围（＆＃34; C15＆＃34;）始终返回该单元格的值。由于QHarr在我们讨论后将其代码更改为Target.Address = Range（＆＃34; C15＆＃34;）。地址此错误不再发生。

Answer 4

使用Find方法对您来说可能更快：

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo exitHandler
    Application.EnableEvents = False
    If Target.Address = "$C$15" Then
        Rows("17:25").EntireRow.Hidden = True
        Dim rng As Range
        Set rng = Me.Range("D17:D25").Find(What:=Target.Value, LookAt:=xlWhole)
        If Not rng Is Nothing Then rng.EntireRow.Hidden = False
    End If

exitHandler:
    Application.EnableEvents = True
End Sub

这个版本首先隐藏范围内的所有行，然后取消隐藏相应的行（如果找到的话），而不是逐行遍历每一行。