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

Question

This is my first post and I'm kind of a beginner; please be gentle. See this link for a reference of the sheet I'm working with.

My plan is to have B2 contain a drop-down list that will be used to selectively collapse certain row groups to just their heading. I've figured out how to collapse one group with this:

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

What I don't have is a way to automatically find the groups. If I use a range like Rows("3:6") and someone adds/removes a row, it won't work. (right?)

What I think I need is a way to identify the required ranges by looking at information in the headers. The reference example is blank, but at the "A" column of each grey row will be a number (100, 101, 150, 380, 420A, 420B, 420C, 890). No number will appear twice, and they will appear in numerical order. The "A" column in the white cells under the gray headers will all be blank.

Is there VBA code that will find the locations of the unique headers so I can use their locations to collapse specific groups?

Additional edit to add new screenshots of what I'm hoping to achieve. Person X, Y, Z all have their predetermined grouping they want expanded or collapsed. And I'd probably add an "all" and "none" if I can figure it out. They'll give me that in advance. The numbers on the left won't ever change. It's only a question of whether Person X wants group 120 expanded or collapsed. https://imgur.com/c2lNujn

Edit to show current code:

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

As @BigBen suggested - use FIND and then Group between the headers - one row down from Start and one row up from End.

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

Instead of hiding and unhiding rows, you can use the Outline.ShowLevels method to collapse the grouping.

So something like this to:

• Test if B1 changed.
• Find the corresponding header in the first column.
• If there's a match, test if the next row has a grouping ( OutlineLevel > 1 ).
• If so, ShowDetail = False for that row.

Note that the use of On Error Resume Next is discouraged. However .ShowDetail = False threw an error when the specified group was already collapsed. As I investigate further, this is the quick fix.

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

Could you abuse your formatting?

Here is tested code:

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

Note:

This question is really really specific. Next time try to break your problem down into smaller chunks and take on 1 question at a time (if anything). Also I strongly recommend including example data to work off of. EG

| 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    | ...