这是我的第一篇文章，我是一个初学者；请保持温柔。有关正在处理的工作表的参考，请参见this link。
我的计划是让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
答案 0 :(得分：0)
按照@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
答案 1 :(得分：0)
您可以使用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
答案 2 :(得分：0)
您会滥用格式吗？
这是经过测试的代码：
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 | ...