Grouping of defined sections

[joshua1990]

Hey guys!

I am currently working on a table or the sections by clicking button group so as to get only a selected area by button.

The first button should only show the current date and group the remaining area.
The second button should check which key is in column 2 for the current date and correspondingly represent only this area and group the other areas.
Button 3 & 4 accordingly.


How is this to handle?
Is this possible by VBA?
I have uploaded a sample file and hope this presents the problem, otherwise I gladly provide further data / information.




Best regards

20760

[SamT]

THis is a Grouping Code I made for another Project.
Option Explicit

Sub GroupingLevel1()
'A Bug in 2003 prevents us of FindNext with Cell Formats
'Groups Ranges by the Colors found in Column A

Dim FoundLevel1 As Range
Dim FirstLevel1Address As String
Dim TopLevel1Cell As Range
Dim BottomLevel1Cell As Range
Dim Level1Exists As Boolean
Dim Level1GroupsRange As Range

Dim LastCell As Range


''''Applies to all Grouping subs
With ActiveSheet
With .Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
'.SummaryColumn = xlLeft
Cells.ClearOutline
End With

Set LastCell = .Cells(Rows.Count, "A").End(xlUp)
Set Level1GroupsRange = Range(.Cells(1), LastCell)
End With

'''' Start of Level one Grouping
Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = Level1BGColor

Set FoundLevel1 = Level1GroupsRange.Cells(1)
Application.FindFormat.Interior.ColorIndex = Level1BGColor


Set FoundLevel1 = Level1GroupsRange.Find(What:="", After:=FoundLevel1, _
SearchDirection:=xlNext, SearchFormat:=True)
If Not FoundLevel1 Is Nothing Then
FirstLevel1Address = FoundLevel1.Address
Level1Exists = True
Do
Set TopLevel1Cell = FoundLevel1.Offset(1)
Application.FindFormat.Interior.ColorIndex = Level1BGColor

Set FoundLevel1 = Level1GroupsRange.Find(What:="", After:=TopLevel1Cell, _
SearchDirection:=xlNext, SearchFormat:=True)

If FoundLevel1.Address <> FirstLevel1Address Then
Set BottomLevel1Cell = FoundLevel1.Offset(-2)
Range(TopLevel1Cell, BottomLevel1Cell).Rows.Group
Else
Set BottomLevel1Cell = LastCell
Range(TopLevel1Cell, BottomLevel1Cell).Rows.Group
End If

GroupingLevel2 Range(TopLevel1Cell, BottomLevel1Cell)
Loop While Level1Exists And FoundLevel1.Address <> FirstLevel1Address
Else
GroupingLevel2 Level1GroupsRange
End If

Set FoundLevel1 = Nothing
End Sub


Sub GroupingLevel2(Level2GroupsRange As Range)

Dim FoundLevel2 As Range
Dim FirstLevel2Address As String
Dim TopLevel2Cell As Range
Dim BottomLevel2Cell As Range
Dim Level2Exists As Boolean

Dim LastCell As Range

With ActiveSheet
With .Outline
.AutomaticStyles = False
.SummaryRow = xlAbove
'.SummaryColumn = xlLeft
End With
End With
Dim X
With Level2GroupsRange
X = .Address
Set LastCell = .Cells(.Cells.Count)
Set FoundLevel2 = .Cells(1)
End With

Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = Level2BGColor


Set FoundLevel2 = Level2GroupsRange.Find(What:="", After:=FoundLevel2, _
SearchDirection:=xlNext, SearchFormat:=True)
If Not FoundLevel2 Is Nothing Then
FirstLevel2Address = FoundLevel2.Address
Level2Exists = True
Do
Set TopLevel2Cell = FoundLevel2.Offset(1)
Application.FindFormat.Interior.ColorIndex = Level2BGColor

Set FoundLevel2 = Level2GroupsRange.Find(What:="", After:=TopLevel2Cell, _
SearchDirection:=xlNext, SearchFormat:=True)

If FoundLevel2.Address <> FirstLevel2Address Then
Set BottomLevel2Cell = FoundLevel2.Offset(-1)
Range(TopLevel2Cell, BottomLevel2Cell).Rows.Group
Else
Set BottomLevel2Cell = LastCell
Range(TopLevel2Cell, BottomLevel2Cell).Rows.Group
End If

GroupingLevel3 Range(TopLevel2Cell, BottomLevel2Cell)
Loop While Level2Exists And FoundLevel2.Address <> FirstLevel2Address
End If

Set FoundLevel2 = Nothing
End Sub



Sub GroupingLevel3(Level3GroupsRange As Range)

Dim FoundLevel3 As Range
Dim FirstLevel3Address As String
Dim TopLevel3Cell As Range
Dim BottomLevel3Cell As Range
Dim Level3Exists As Boolean

Dim LastCell As Range


With Level3GroupsRange
Set LastCell = .Cells(.Cells.Count)
Set FoundLevel3 = .Cells(1)
End With

Dim X
X = FoundLevel3.Address
Application.FindFormat.Clear
Application.FindFormat.Interior.ColorIndex = Level3BGColor


If Not FoundLevel3 Is Nothing Then
FirstLevel3Address = FoundLevel3.Address
Level3Exists = True

Do While Level3Exists
Set TopLevel3Cell = FoundLevel3.Offset(1)
Application.FindFormat.Interior.ColorIndex = Level3BGColor

Set FoundLevel3 = Level3GroupsRange.Find(What:="", After:=TopLevel3Cell, _
SearchDirection:=xlNext, SearchFormat:=True)

If FoundLevel3.Address <> FirstLevel3Address Then
Set BottomLevel3Cell = FoundLevel3.Offset(-1)
Range(TopLevel3Cell, BottomLevel3Cell).Rows.Group
Else
Set BottomLevel3Cell = LastCell
Range(TopLevel3Cell, BottomLevel3Cell).Rows.Group
End If

Set FoundLevel3 = Level3GroupsRange.Find(What:="", After:=BottomLevel3Cell, _
SearchDirection:=xlNext, _
SearchFormat:=True)

If FoundLevel3.Address = FirstLevel3Address Then Exit Do
Loop
End If

Set FoundLevel3 = Nothing
End Sub

[joshua1990]

Do I need this Line?
Application.FindFormat.Interior.ColorIndex = Level3BGColor

[SamT]

Not unless you're grouping by cell color.