Using VBA to identify ranges based on specific values - excel

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

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

Answer 2

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 3

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