VBA code to update table of contents

[springate]

Hi all, i'm looking for some code that will update my table of contents sheet 'Index' with the sheet name list and hyperlink in column A whilst preserving the data in the other columns.

At present the code updates the list without inserting new rows for new sheets which causes my data in the other columns to not align to the sheet it belongs to.

Thanks!

 

[jkpieterse]

See my article on building an Excel add-in, which happens to have a ToC function: Excel: Building an Excel add-in
In fact, why not "just" download and install that add-in

 

[springate]

The VBA Code at present is:

Private Sub Worksheet_Activate()
Dim wSheet As Worksheet
Dim M As Long
M = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
End With

For Each wSheet In Worksheets
If wSheet.Name <> Me.Name Then
M = M + 1
With wSheet
.Range("M1").Name = "Start" & wSheet.Index
.Hyperlinks.Add Anchor:=.Range("M1"), Address:="", SubAddress:="Index", TextToDisplay:="Back to Index"
End With
Me.Hyperlinks.Add Anchor:=Me.Cells(M, 1), Address:="", SubAddress:="Start" & wSheet.Index, TextToDisplay:=wSheet.Name
End If
Next wSheet
End Sub

 

[Alex Blakenburg]

If you don't want to use Jan's add-in which will be much more professional than anything I can come up you can give this a try:

Private Sub Worksheet_Activate()
    Dim wSheet As Worksheet
    Dim M As Long, i As Long, iOrig As Long, j As Long
    Dim rngOrig As Range
    Dim arrOrig As Variant, arrOut As Variant
    Dim dictOrig As Object, dictKey As String
    
    Application.ScreenUpdating = False
    
    Set rngOrig = Me.Range("A1").CurrentRegion
    arrOrig = rngOrig.Value

    Set dictOrig = CreateObject("Scripting.dictionary")
    dictOrig.CompareMode = vbTextCompare
    
    ' Load original index into Dictionary
    For i = 1 To UBound(arrOrig)
        dictKey = arrOrig(i, 1)
        If Not dictOrig.exists(dictKey) Then
            dictOrig(dictKey) = i
        End If
    Next i
 
    M = 1
    With Me
        .Columns(1).ClearContents
        .Cells(1, 1) = "INDEX"
        .Cells(1, 1).Name = "Index"
    End With
    
    ReDim arrOut(1 To ThisWorkbook.Worksheets.Count, 1 To UBound(arrOrig, 2) - 1)   ' Drop Column A
    
    For Each wSheet In Worksheets
        If wSheet.Name <> Me.Name Then
            M = M + 1
            With wSheet
                .Range("M1").Name = "Start" & wSheet.Index
                .Hyperlinks.Add Anchor:=.Range("M1"), Address:="", SubAddress:="Index", TextToDisplay:="Back to Index"
            End With
            Me.Hyperlinks.Add Anchor:=Me.Cells(M, 1), Address:="", SubAddress:="Start" & wSheet.Index, TextToDisplay:=wSheet.Name
            
            dictKey = wSheet.Name
            If dictOrig.exists(dictKey) Then
                iOrig = dictOrig(dictKey)
                For j = 1 To UBound(arrOut, 2)
                    arrOut(M - 1, j) = arrOrig(iOrig, j + 1)
                Next j
            End If
        End If
    Next wSheet
    
    Me.Range("B2").Resize(M - 1, UBound(arrOut, 2)).Value = arrOut
    
    Application.ScreenUpdating = True
End Sub

 

[springate]

If you don't want to use Jan's add-in which will be much more professional than anything I can come up you can give this a try:

Private Sub Worksheet_Activate()
    Dim wSheet As Worksheet
    Dim M As Long, i As Long, iOrig As Long, j As Long
    Dim rngOrig As Range
    Dim arrOrig As Variant, arrOut As Variant
    Dim dictOrig As Object, dictKey As String
   
    Application.ScreenUpdating = False
   
    Set rngOrig = Me.Range("A1").CurrentRegion
    arrOrig = rngOrig.Value

    Set dictOrig = CreateObject("Scripting.dictionary")
    dictOrig.CompareMode = vbTextCompare
   
    ' Load original index into Dictionary
    For i = 1 To UBound(arrOrig)
        dictKey = arrOrig(i, 1)
        If Not dictOrig.exists(dictKey) Then
            dictOrig(dictKey) = i
        End If
    Next i
 
    M = 1
    With Me
        .Columns(1).ClearContents
        .Cells(1, 1) = "INDEX"
        .Cells(1, 1).Name = "Index"
    End With
   
    ReDim arrOut(1 To ThisWorkbook.Worksheets.Count, 1 To UBound(arrOrig, 2) - 1)   ' Drop Column A
   
    For Each wSheet In Worksheets
        If wSheet.Name <> Me.Name Then
            M = M + 1
            With wSheet
                .Range("M1").Name = "Start" & wSheet.Index
                .Hyperlinks.Add Anchor:=.Range("M1"), Address:="", SubAddress:="Index", TextToDisplay:="Back to Index"
            End With
            Me.Hyperlinks.Add Anchor:=Me.Cells(M, 1), Address:="", SubAddress:="Start" & wSheet.Index, TextToDisplay:=wSheet.Name
           
            dictKey = wSheet.Name
            If dictOrig.exists(dictKey) Then
                iOrig = dictOrig(dictKey)
                For j = 1 To UBound(arrOut, 2)
                    arrOut(M - 1, j) = arrOrig(iOrig, j + 1)
                Next j
            End If
        End If
    Next wSheet
   
    Me.Range("B2").Resize(M - 1, UBound(arrOut, 2)).Value = arrOut
   
    Application.ScreenUpdating = True
End Sub

Awesome Thanks Alex!

I've just tried it on a small sheet and i'll test it out on the proper one tomorrow!!

 

[springate]

Thanks Alex, that code worked a treat,
only thing i'm worried about now is if other users insert a row on the index page, rather than adding a tab, to add a new 'record'. Upon activating the index sheet it drops the new row to the bottom and renames the data in the row after the last tab in the list.

If I could get the code to preserve that new text-filled row and create a new tab named from the text in column B that would be awesome

I am basically trying to get MS Excel to act like Access as our business does not have access to Access.

Thanks

 

[Alex Blakenburg]

You will need to give me visual of what you want to happen.

 

[springate]

So my table is a list of Electrical Distribution Board Legends (a list of circuit breakers). Each line is a DB and the corresponding sheet will be the legend.

If an Electrician decides to add a new legend then they would either add new sheet on the + button down the bottom or they might insert a new row and enter the other info (in the column headers)
like this

then once they navigate away from the index sheet and back the code does this

making the S03_LPDB01 legend hyperlink now separated from its row, and DS1_LPDB01's info now deleted completely.

The tabs are ordered in terms of power flow so new tabs may not necessarily be added to the bottom of the list.

Is it possible for the code to recognise a new row and name the new sheet after the text in the B column?

Otherwise I can just tell my fellow leccys to only add new sheets down the bottom.. probably easier really..lol

 

[springate]

P.S. my actual sheet is hundreds of lines long which makes navigating by the hyperlinks much easier than using the tabs at the bottom

 

[Alex Blakenburg]

Try this:
In the Worksheet_Activate Event replace the code up to "Set = dictOrig" with this:

    Dim wSheet As Worksheet
    Dim M As Long, i As Long, iOrig As Long, j As Long
    Dim rowLast As Long
    Dim rngOrig As Range
    Dim arrOrig As Variant, arrOut As Variant
    Dim dictOrig As Object, dictKey As String
    
    Application.ScreenUpdating = False
    
    rowLast = Me.Range("A" & Rows.Count).End(xlUp).Row
    Set rngOrig = Me.Range("A1").CurrentRegion.Resize(rowLast)
    arrOrig = rngOrig.Value

Then assuming the user enters a sheet name in column B and leaves column A blank, add this Worksheet_Deactivate code.
It will add a sheet for the new name and set up the hyperlinks.

Private Sub Worksheet_DeActivate()
    Dim i As Long, shtIndx As Long, j As Long
    Dim rowLast As Long
    Dim rngOrig As Range
    Dim arrOrig As Variant
    
    Application.ScreenUpdating = False
    
    rowLast = Me.Range("B" & Rows.Count).End(xlUp).Row              ' Use Name Column
    Set rngOrig = Me.Range("A1").CurrentRegion.Resize(rowLast)
    arrOrig = rngOrig.Value
 
    For i = 2 To UBound(arrOrig)
        shtIndx = i
        If arrOrig(i, 1) = "" And arrOrig(i, 2) <> "" Then
            If Not Evaluate("isref('" & arrOrig(shtIndx, 2) & "'!A1)") Then
                Worksheets.Add(after:=Worksheets(shtIndx - 1)).Name = arrOrig(i, 2)
            End If
            With Worksheets(arrOrig(i, 2))
                .Range("M1").Name = "Start" & .Index
                .Hyperlinks.Add Anchor:=.Range("M1"), Address:="", SubAddress:="Index", TextToDisplay:="Back to Index"
                Me.Hyperlinks.Add Anchor:=Me.Cells(i, 1), Address:="", SubAddress:="Start" & .Index, TextToDisplay:=.Name
            End With

        End If
    
    Next i
    
    Application.ScreenUpdating = True
End Sub