Table of Contents with Tab Colour

[rilzniak]

Hey everyone,

I've tried a few different things but can't seem to figure out how to add the tab colour from the worksheet to the cell within the Table of Contents I created for myself. Below is what I have so far, but something isn't working:

Sub HyperlinkTOC()

Dim i As Long
Dim LinkCell As Variant
On Error Resume Next


Application.DisplayAlerts = False
Application.DisplayAlerts = True


LinkCell = InputBox("Which would you like to be the linked active cell?")


On Error GoTo 0
'ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)
'ActiveSheet.Name = "Table of Content"


For i = 1 To Sheets.Count


    With ActiveSheet
        .Hyperlinks.Add _
        Anchor:=ActiveSheet.Cells(ActiveCell.Row - 1 + i, ActiveCell.Column), _
        Address:="", _
        SubAddress:="'" & Sheets(i).Name & "'!" & LinkCell, _
        ScreenTip:=Sheets(i).Name, _
        TextToDisplay:=Sheets(i).Name
    End With


    Worksheets(i).Tab.ColorIndex = ActiveCell.Interior.ColorIndex


Next i


ActiveCell.Delete


End Sub

I'm probably not on the right path, but hoping someone can point me in the right direction. Thanks.

 

[Yongle]

Is this what you want?
- cell containing the hyperlink made the same colour as the tab

("Table of Content" is a new sheet and its cells have not been filled so making the tab match the cell would change nothing)

Error handling inserted to deal with situation where index requires refreshing when sheet "Table of Content" already exists
Variable sName used to avoid repeating Sheets(i).Name

Sub HyperlinkTOC()

    Dim i As Long, [COLOR=#000080]AnchorCell[/COLOR] As Range, sName As String
    Dim LinkCell As Variant
    LinkCell = InputBox("Which would you like to be the linked active cell?")

'add new index sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Table of Content").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1)
    ActiveSheet.Name = "Table of Content"

'add hyperlink to every other sheet
    For i = 2 To Sheets.Count
    
        With ActiveSheet
            [COLOR=#000080]Set AnchorCell = ActiveSheet.Cells(ActiveCell.Row - 1 + i, ActiveCell.Column)
            AnchorCell.Interior.ColorIndex = Worksheets(i).Tab.ColorIndex[/COLOR]
            sName = Sheets(i).Name
            .Hyperlinks.Add _
                Anchor:=[COLOR=#000080]AnchorCell[/COLOR], _
                Address:="", _
                SubAddress:="'" & sName & "'!" & LinkCell, _
                ScreenTip:=sName, _
                TextToDisplay:=sName
        End With
    
    Next i

End Sub

This would force the user to enter a valid range

Set LinkCell = Application.InputBox("Which would you like to be the linked active cell?", , , , , , , 8)
LinkCell = LinkCell(1).Address

 

[rilzniak]

Sorry, forgot to reply. This is almost perfect. The only issue is that the colours seem to be off. Do you know of a way to get the RGB values and use those instead of using the line below?

[COLOR=#000080] AnchorCell.Interior.ColorIndex = Worksheets(i).Tab.ColorIndex[/COLOR]

 

[Yongle]

How about

AnchorCell.Interior.Color = Worksheets(i).Tab.Color

 

[rilzniak]

Works perfectly! Thanks!

 

[rilzniak]

For aesthetics, how would I go about changing the font colour to that of the worksheet. I tried:

[COLOR=#000080]AnchorCell.font.Color = Worksheets(i).font.Color[[/COLOR]/CODE] but that didn't seem to work. Also, I can't figure out how to remove the underline from the pasted cell. Any recommendations?

 

[Taul]

try this

AnchorCell.Font.Color = RGB(255, 0, 125)

and place it here.
I change a few other things because I did not want to delete the TOC page and create a new one, mainly as I assigned the macro to "Refresh" button

Sub HyperlinkTOC()


    Dim i As Long, AnchorCell As Range, sName As String
    Dim LinkCell As Variant
   ' LinkCell = InputBox("Which would you like to be the linked active cell?")
    LinkCell = "A1" 'use A1 as a default value or use the input box above


'add new index sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    'Sheets("Table of Content").Delete' no need to delete this page
    Application.DisplayAlerts = True
    On Error GoTo 0
    'ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Worksheets(1) 'no need to add a new workbook
    'ActiveSheet.Name = "Table of Content" 'no need to add a new worksheet


'add hyperlink to all other sheets
    For i = 2 To Sheets.Count
    
        With ActiveSheet
            'Set AnchorCell = ActiveSheet.Cells(ActiveCell.Row - 1 + i, ActiveCell.Column)
            Set AnchorCell = ActiveSheet.Range("B" & "3" + i) ' prefer to fix the cell start point
            
            'AnchorCell.Interior.ColorIndex = Worksheets(i).Tab.ColorIndex 'colour is a bit off
            AnchorCell.Interior.Color = Worksheets(i).Tab.Color ' use this approach
            sName = Sheets(i).Name
               .Hyperlinks.Add _
                Anchor:=AnchorCell, _
                Address:="", _
                SubAddress:="'" & sName & "'!" & LinkCell, _
                ScreenTip:=sName, _
                TextToDisplay:=sName
               AnchorCell.Font.Color = RGB(255, 0, 255)
        End With
    Next i
End Sub

Thank you Yongle, nice piece of code that I would like to use on my own project.

 

[Taul]

or use cell A1 to have the font colour of your choice on each page

AnchorCell.Font.Color = Worksheets(i).Range("A1").Font.Color

cheers
Paul.

 

[rilzniak]

try this

AnchorCell.Font.Color = RGB(255, 0, 125)

Doesn't that make the font pink?

What I was hoping to find out is how to change the font colour to match that of the worksheet. Ex: If the sheet tab colour is black, the font will be white; if the sheet tab colour is yellow, the font will be black. I would want the output in the TOC to match that same logic.

 

[Taul]

Hi,
As far as I know, you can't change the tab font colour.
The fact that it changes to white with darker background colours is hard coded into excel.
Having said that, someone else may prove me wrong and show how it can be done (fingers crossed)

cheers
Paul.

edit - see post #8 for an update on the font colour based on cell A1 on each page