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