Automate Table of Contents with 3 sections

[rahildhody]

Hi,

I have a macro that produces table of contents based on a section separator suffix that's defined in the ToC sheet.

It currently runs the macro on only 1 subsection: i.e. I can only go down to 1.1, 1.2 etc.

I would like this code to be modified to include a third subsection, again defined at the top as perhaps _SubSC that would perform the same function at the current code but for section 1.1.1, 1.1.2, 1.2.1 etc.

Any help on this matter would be greatly appreciated.

Option Explicit

Sub ToC()
StartAppSettings

    Dim shtAct As Worksheet, shtToC As Worksheet
    Dim rngErrorCol As Range, rngSectSuff As Range, rngStartCell As Range
    Dim lngToCSection As Long, lngToC As Long, lngToCSub As Long
    Dim strText As String
    Dim calcMeth As XlCalculation
    Dim nSheets
    
    Set rngErrorCol = ThisWorkbook.Names("ToC_Err_Column").RefersToRange
    Set rngSectSuff = ThisWorkbook.Names("ToC_Section_Suffix").RefersToRange
    Set rngStartCell = ThisWorkbook.Names("ToC_Start_Cell").RefersToRange
    
'application level settings

    
    
    Set shtToC = Sheets("ToC")
    
'Placeholder sheets that do not need to be in ToC
    nSheets = Array("ToC", "DPD", "Tableau PnL", "Portfolio Mapping", "Opex Allocations", "Portfolio Import", "PnL Import", "Strat Cube Import", "Lending Fees Import", "FTE Import")
    
'check if ToC sheet exists; if not, create Toc sheet
    
    rngStartCell.Offset(2, 1).Resize(shtToC.UsedRange.Rows.Count - rngStartCell.Rows.Count + 2, 6).ClearContents
    
    On Error Resume Next
    rngStartCell.Offset(2, 1).Resize(shtToC.UsedRange.Rows.Count - rngStartCell.Rows.Count + 2).EntireRow.Ungroup
    On Error GoTo 0
    
'Add Error Check total label
    rngStartCell.Offset(2, 5).Value = "Errors"
    
    For Each shtAct In ActiveWorkbook.Worksheets
        If Not (IsNumeric(Application.Match(shtAct.Name, nSheets, 0))) Then 'shtAct.Name <> nSheets
            lngToC = lngToC + 1
            
                If InStr(shtAct.Name, rngSectSuff.Value) > 0 Then
                    
                    lngToCSection = lngToCSection + 1
                    lngToCSub = 0
                    
                    Call f_Hyperlink(rngStartCell.Offset(lngToC + 2, 1), shtAct, shtToC, CStr(lngToCSection))
                    Call f_Hyperlink(rngStartCell.Offset(lngToC + 2, 3), shtAct, shtToC, shtAct.Name)
                    
                ElseIf Not (IsNumeric(Application.Match(shtAct.Name, nSheets, 0))) Then 'shtAct.Name <> nSheets
                    
                    lngToCSub = lngToCSub + 1
                    
                    Call f_Hyperlink(rngStartCell.Offset(lngToC + 2, 2), shtAct, shtToC, CStr(lngToCSection & "." & lngToCSub))
                    Call f_Hyperlink(rngStartCell.Offset(lngToC + 2, 3), shtAct, shtToC, shtAct.Name)
                    
                    rngStartCell.Offset(lngToC + 2, 1).EntireRow.Group
                    rngStartCell.Offset(lngToC + 2, 3).IndentLevel = 3
                    
                    'Add error Checks
                    rngStartCell.Offset(lngToC + 2, 4).Formula = "=Sum('" & shtAct.Name & "'!" & rngErrorCol.Value & ":" & rngErrorCol.Value & ")"
                    If InStr(rngStartCell.Offset(lngToC + 2, 4).Value, "#") > 0 Then
                        rngStartCell.Offset(lngToC + 2, 4).Formula = "=Sum(" & shtAct.Name & "!A:A)"
                    End If
                    
                End If
        End If
        
    Next shtAct
    
'total errors
    rngStartCell.Offset(2, 4).Formula = "=Sum(" & rngStartCell.Offset(3, 4).Resize(lngToC + 1, 1).Address & ")"
    
'Add formatting
    rngStartCell.Offset(3, 4).Resize(lngToC + 2, 1).NumberFormat = "#,##0;[Red](#,##0);--"
    rngStartCell.Offset(3, 4).Resize(lngToC + 2, 1).HorizontalAlignment = xlCenter
    rngStartCell.Offset(3, 4).Resize(lngToC + 2, 1).VerticalAlignment = xlCenter
    
    rngStartCell.Offset(2, 1).Resize(lngToC + 2, 3).Font.Color = RGB(149, 79, 114)
    
    rngStartCell.Offset(2, 1).Resize(shtToC.UsedRange.Rows.Count - rngStartCell.Rows.Count + 2, 6).Font.Size = 8
    rngStartCell.Offset(2, 1).Resize(shtToC.UsedRange.Rows.Count - rngStartCell.Rows.Count + 2, 6).Font.Name = "Arial"
    
    Set rngErrorCol = Nothing
    Set rngSectSuff = Nothing
    Set rngStartCell = Nothing
    
'application level settings
EndAppSettings
    
End Sub

Function f_Hyperlink(rngToCPosition As Range, shtAct As Worksheet, shtToC As Worksheet, strText As String)

    shtToC.Hyperlinks.Add rngToCPosition, "", "'" & shtAct.Name & "'!$A$1", "Go to Sheet", strText

End Function