Untitled
Private Sub Worksheet_Change(ByVal Target As Range) Dim yearsInCompany As Long Dim totalGroups As Long Dim startCol As Long Dim endCol As Long Dim colRange As String Dim i As Long Dim k7Value As String Dim splitValues() As String ' Unprotect the sheet Me.Unprotect Password:="111111" ' Unlock grouped columns Me.Columns("Q:CU").Locked = False ' Check if K6 or K7 was changed If Not Intersect(Target, Me.Range("K6:K7")) Is Nothing Then Application.EnableEvents = False ' Prevent recursive triggers Debug.Print "Change detected in K6 or K7" ' Debugging ' Validate K7 value If IsEmpty(Me.Range("K7").Value) Then Me.Columns("Q:CR").Hidden = True Me.Outline.ShowLevels ColumnLevels:=1 ' Reapply protection with UserInterfaceOnly to enable Outliner and allow grouping Me.Protect Password:="111111", _ UserInterfaceOnly:=True, AllowFormattingColumns:=True Me.EnableOutlining = True ' Enable Outlining after protection Application.EnableEvents = True Exit Sub End If ' Extract "years" from K7 k7Value = Me.Range("K7").Value splitValues = Split(k7Value, " years") ' Split based on " years" If UBound(splitValues) >= 0 Then yearsInCompany = Val(splitValues(0)) ' Get the numeric value before " years" Else yearsInCompany = 0 ' Default if no years found End If ' Ensure at least 1 year is considered yearsInCompany = yearsInCompany + 1 ' Define grouping parameters totalGroups = 20 ' 20 groups, 4 columns each startCol = 17 ' Column Q is the 17th column ' Loop through groups to hide/unhide For i = 1 To totalGroups endCol = startCol + 3 ' Each group spans 4 columns ' Convert column numbers to letters Dim startColLetter As String, endColLetter As String startColLetter = Split(Me.Cells(1, startCol).Address(False, False), "$")(0) endColLetter = Split(Me.Cells(1, endCol).Address(False, False), "$")(0) If i <= yearsInCompany Then ' Unhide the group while keeping it collapsed Me.Range(startColLetter & ":" & endColLetter).EntireColumn.Hidden = False Else ' Hide the group Me.Range(startColLetter & ":" & endColLetter).EntireColumn.Hidden = True End If ' Move to the next group startCol = startCol + 4 Next i ' Collapse all groups Me.Outline.ShowLevels ColumnLevels:=1 End If ' Reapply protection and enable outlining Me.Protect Password:="111111", UserInterfaceOnly:=True, AllowFormattingColumns:=True Me.EnableOutlining = True ' Ensure events are re-enabled Application.EnableEvents = True Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Debug.Print "Error: " & Err.Number & " - " & Err.Description Application.EnableEvents = True End Sub
Leave a Comment