时间戳

首页 > 解决方案 > 使用 VBA 根据特定值识别范围

excel - 使用 VBA 根据特定值识别范围

问题描述

这是我的第一篇文章，我是一个初学者；请温柔一点。请参阅此链接以获取我正在使用的工作表的参考。

我的计划是让 B2 包含一个下拉列表，用于选择性地将某些行组折叠到它们的标题。我已经想出了如何用这个来折叠一组：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    Set KeyCells = Range("B1")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
        Is Nothing Then

       If Range("B1") = "All" Then
            Rows("3:6").Select
            Selection.EntireRow.Hidden = False
            Range("B1").Select
       Else
            Rows("3:6").Select
            Selection.EntireRow.Hidden = True
            Range("B1").Select
       End If

    End If

End Sub

我没有的是一种自动查找组的方法。如果我使用像 Rows("3:6") 这样的范围并且有人添加/删除一行，它将不起作用。（正确的？）

我认为我需要的是一种通过查看标题中的信息来识别所需范围的方法。参考示例是空白的，但在每个灰色行的“A”列将是一个数字（100、101、150、380、420A、420B、420C、890）。没有数字会出现两次，它们会按数字顺序出现。灰色标题下的白色单元格中的“A”列将全部为空白。

是否有 VBA 代码可以找到唯一标题的位置，以便我可以使用它们的位置来折叠特定组？

附加编辑以添加我希望实现的新屏幕截图。人 X、Y、Z 都有他们想要展开或折叠的预定分组。如果我能弄清楚，我可能会添加“全部”和“无”。他们会提前给我的。左边的数字永远不会改变。这只是一个问题，即人 X 是否希望组 120 扩大或折叠。https://imgur.com/c2lNujn

编辑以显示当前代码：

Public HeaderColor As Long


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Me.HeaderColor = RGB(217, 217, 217)

    'If A1 is true, group rows
    If Range("A1").Value Then
        'Use getRegion function on target
        Dim rng As Range
        Set rng = getRegion(Target)

        'If the returned range is nothing then end sub
        If rng Is Nothing Then Exit Sub

        'Select region
        Application.EnableEvents = False
            rng.Select
        Application.EnableEvents = True
    End If

    'If D1 is true, apply Y/N options for selection in C1
    If Range("D1").Value Then

    Dim rngX As Range, c As Range
    Set rngX = Worksheets("Options").Range("A1:N1").Find(Range("C1"), lookat:=xlPart)

    If Not rngX Is Nothing Then
        'MsgBox Chr(34) & Range("C1").Value & Chr(34) & " found at " & rngX.Address
    End If

'Check
'    Dim groupcounter As Long
'    For groupcounter = 1 To 80
'        If Worksheets("Options").Range(rngX.Column, groupcounter + 1) = "Y" Then
'            getNthRegion(ActiveSheet, groupcounter).Hidden = True
'        ElseIf Worksheets("Options").Range(rng.Column, groupcounter + 1) = "N" Then
'            getNthRegion(ActiveSheet, groupcounter).Hidden = False
'        End If
'    Next groupcounter
End If


End Sub
Sub customiseVisibility(ByVal query As String)
    Dim cell As Range
    Set cell = OptionsSheet.Range("1:1").Find(query)
    Dim offset As Long
    offset = 1
    While Not IsEmpty(cell.offset(offset))
        getNthRegion(MySheet, offset).Hidden = cell.offset(offset).Value = "N"
        offset = offset + 1
    Wend
End Sub

Private Function getRegion(cell As Range) As Range
    Dim formatted As Boolean
    Dim cell_start, cell_end As Range

    'If cell row is 1 then exit function
    If cell.Row <= 1 Then Exit Function

    'If cell row count > 1 then use first cell selected
    If cell.Rows.Count > 1 Then Set cell = cell.Cells(1, 1)

    'If selection is outside of used range, do nothing
    If Application.Intersect(cell, cell.Parent.UsedRange) Is Nothing Then Exit Function

    'Special condition
    If cell.Interior.Color = Me.HeaderColor Then
        'Select row below
        Set cell = cell.offset(1)
    End If

    'Get start cell
    Set cell_start = cell
    While Not cell_start.Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_start, cell.Parent.UsedRange) Is Nothing ' Your gray color
        Set cell_start = cell_start.offset(-1)
    Wend

    'Get end cell
    Set cell_end = cell
    While Not cell_end.offset(iRowEnd, 0).Interior.Color = Me.HeaderColor And Not Application.Intersect(cell_end, cell.Parent.UsedRange) Is Nothing ' Your gray color
        Set cell_end = cell_end.offset(1)
    Wend

    'Get region
    Set getRegion = Range(cell_start.offset(1), cell_end.offset(-1)).EntireRow
End Function

Function getNthRegion(ByVal sheet As Worksheet, ByVal n As Long) As Range
    Dim i, counter As Long
    For i = 1 To sheet.UsedRange.Rows.Count
       If sheet.Cells(i, 1).Interior.Color = HeaderColor Then
          counter = counter + 1
       End If
       If counter = n Then
           Set getNthRegion = getRegion(sheet.Cells(i, 1))
           Exit Function
       End If
    Next
End Function

标签： excelvba

解决方案

Outline.ShowLevels您可以使用该方法折叠分组，而不是隐藏和取消隐藏行。

所以这样的事情：

  • 测试是否B1改变。
  • Find第一列中的相应标题。
  • 如果匹配，则测试下一行是否有分组 ( OutlineLevel > 1)。
  • 如果是这样，ShowDetail = False对于该行。

请注意，On Error Resume Next不鼓励使用 。但是.ShowDetail = False，当指定的组已经折叠时会引发错误。当我进一步调查时，这是快速修复。

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Me.Range("B1"), Target) Is Nothing Then
        With Me
            Dim rng As Range
            Set rng = .Columns(1).Find(.Range("B1").Value)

            If Not rng Is Nothing Then
                With rng.Offset(1).EntireRow
                    On Error Resume Next
                    If .OutlineLevel > 1 Then .ShowDetail = False
                End With
            End If
        End With
    End If
End Sub

推荐阅读