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

Question

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

我的计划是让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人都有他们想要扩展或折叠的预定组。 如果我能弄清楚的话，我可能会添加“ all”和“ none”。 他们会提前给我的。 左边的数字永远不会改变。 这只是Person 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

Answer 1

正如@BigBen建议的那样-使用FIND ，然后在标题之间进行分组-从“开始”向下一行，从“结束”向上一行。

Public Sub CreateOutline()

    Dim sFirstAdd As String
    Dim rFound As Range
    Dim rStart As Range
    Dim rEnd As Range

    With ThisWorkbook.Worksheets("Sheet1")

        .Cells.ClearOutline 'Remove any existing.

        With .Cells.EntireColumn
            Set rFound = .Find(What:="*", _
                               After:=.Cells(1, 1), _
                               LookIn:=xlValues, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext)

            If Not rFound Is Nothing Then
                sFirstAdd = rFound.Address
                Do
                    Set rStart = rFound
                    Set rFound = .FindNext(rFound)
                    Set rEnd = rFound

                    Range(rStart.Offset(1), rEnd.Offset(-1)).Rows.Group

                    'Include a marker to state where the end of the last section is.
                    'Otherwise the last section will go from cell A1 to just below last section header.
                    If rEnd = "End" Then sFirstAdd = rFound.Address

                Loop While rFound.Address <> sFirstAdd
            End If

        End With
    End With

End Sub

Answer 2

代替隐藏和Outline.ShowLevels隐藏行，可以使用Outline.ShowLevels方法折叠分组。

所以像这样：

• 测试B1更改。
• 在第一列中Find相应的标题。
• 如果有匹配项，请测试下一行是否有分组（ OutlineLevel > 1 ）。
• 如果是这样， ShowDetail = False该行的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

Answer 3

您会滥用格式吗？

这是经过测试的代码：

Public  HeaderColor  as Long
Private OptionsSheet as Worksheet
Private DataSheet    as Worksheet

Private Sub Worksheet_Change(ByVal Target As Range)
  Me.HeaderColor = RGB(217, 217, 217)
  set OptionsSheet = sheets("Options")
  set DataSheet = ActiveWorksheet

  if target.address = "$B$1" then
    customiseVisibility target.value
  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(DataSheet, 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

注意：

这个问题真的很具体。 下次尝试将您的问题分解为较小的部分，并一次处理一个问题（如果有的话）。 另外，我强烈建议您添加示例数据进行处理。 例如

| Number | All | PersonA | PersonB | ...
-----------------------------------------
|   1    |  N  |    Y    |    N    | ...
|   2    |  N  |    Y    |    N    | ...
|   3    |  N  |    Y    |    N    | ...
|   4    |  N  |    Y    |    Y    | ...
|   5    |  N  |    N    |    N    | ...
|   6    |  N  |    N    |    Y    | ...
|   7    |  N  |    N    |    N    | ...
|   8    |  N  |    N    |    Y    | ...