根據單元格值自動隱藏對應的行

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行），並且當我嘗試在表的其余部分進行任何更改時，它拋出一個錯誤-

“運行時錯誤'13'：類型不匹配”。

我沒有宏的經驗，也不確定自己在做什么錯。 您能否幫助我更正代碼。 如果有更好的方法可以更有效地完成同一任務，請告訴我。

Answer 1

循環遍歷幾百（甚至幾千）行以檢查hidden屬性將足夠快地運行。 關鍵是將檢查僅限制在所需的單元格上，並在一次操作中執行“隱藏/取消隱藏”（如果一次執行一次，則這是慢速位）

使用邏輯：

• 如果單元格C15發生更改，請檢查整個列表，或者
• 如果列表D17:D25 （或更大）中的一個或多個單元格更改，則僅處理更改的單元格
• 建立必須更改隱藏狀態的行的引用，並為整個范圍設置Hidden屬性

該代碼實際上在幾千行的列表范圍內立即運行

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的原因是目標行= Range（“ C15”）。 如果選擇多個單元格，則將范圍與值進行比較，因為Range（“ C15”）始終返回該單元格的值。 在我們討論完QHarr之后將其代碼更改為Target.Address = Range（“ C15”）。Address之后，此錯誤將不再發生。

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

此版本不是逐一遍歷每行，而是先隱藏范圍內的所有行，然后取消隱藏適當的行（如果找到）。