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.

 

[Taul]

Hi, forgot to answer another part of the question, the underline is part of being a hyperlink but you can turn them off

AnchorCell.Font.Underline = False

cheers
Paul

 

[rilzniak]

No, I'm aware of that. What I was looking to do was to match the output of the tab colour scheme. If I hard-code the cell colour to black and then past a black fill on top I won't be able to see what it says in that cell. So, I was looking to see how I could utilize the worksheet's tab font colour and incorporate that into the pasted TOC. Does that make sense? Sorry, hard to explain this one.

 

[Yongle]

deleted by yongle

 

[Taul]

Hi,
Yes, I understand what you are trying to achieve and although we can get the tab back colour and put it into the ToC page via the code, we cannot get the tab font colour.
The best I can offer, albeit a compromise, is to use the code shown in post #8 and then manually style the font colour in cell A1 on each of the pages. That way the code will pick up the font colour from Cell A1 on each page and apply it to the ToC page

cheers
Paul.

 

[Taul]

Hi,
After doing a little searching I came across an interesting post over at Ozgrid.
https://www.ozgrid.com/forum/forum/...-or-white-font-based-on-cell-background-color
Quote from the above post:-
“The Luminance Formula:
R * 0.3 + G * 0.59 + B * 0.11 = L
This is the formula for Luminance, or the brightness of a color.
It is most commonly used to convert colors to grayscale.”

Sub SetFontColor()
    Dim cell As Range
    For Each cell In Selection
        cell.Font.Color = BorW(cell.Interior.Color)
    Next cell
End Sub
 
Function BorW(RGB As Long) As Long
    Dim R As Integer, G As Integer, B As Integer
    R = (RGB And &HFF)
    G = (RGB And &HFF00&) / 256
    B = (RGB And &HFF0000) / 65536
    BorW = vbWhite
    If R * 0.3 + G * 0.59 + B * 0.11 > 128 Then BorW = vbBlack
End Function

I have basically appended this to the end of the original ToC code and in addition I have added an “IF” statement to first check if a Tab background colour has been applied, this should avoid getting a black background in the ToC cell when no colour has been set on the Tab.

I have only done a little bit of checking and it looks like it works ok, hopefully it will provide what you need.

Cheers
Paul.

Full ToC code:-

Function BorW(RGB As Long) As Long
    Dim R As Integer, G As Integer, B As Integer
    R = (RGB And &HFF)
    G = (RGB And &HFF00&) / 256
    B = (RGB And &HFF0000) / 65536
    BorW = vbWhite
    If R * 0.3 + G * 0.59 + B * 0.11 > 128 Then BorW = vbBlack
End Function
 
 
 
Sub HyperlinkTOC()
'Table of Contents
Dim i As Long, AnchorCell As Range, sName As String
Dim LinkCell As Variant
'Dim cell As Range
'Dim BorW As Long
 
' 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
 
'Clear previous list
Range("B3:B100").ClearContents 'guessing there will not be more than 100 sheets
Range("B3:B100").ClearFormats
 
'add hyperlink for all other sheets
For i = 2 To Sheets.Count 'ensure ToC sheet is the first sheet on the LHS
    With ActiveSheet
        'Set AnchorCell = ActiveSheet.Cells(ActiveCell.Row - 1 + i, ActiveCell.Column)
        Set AnchorCell = ActiveSheet.Range("B" & "2" + i) ' prefer to fix the cell start point
           
        If Worksheets(i).Tab.ColorIndex = xlColorIndexNone Then
            sName = Sheets(i).Name
               .Hyperlinks.Add _
                Anchor:=AnchorCell, _
                Address:="", _
                SubAddress:="'" & sName & "'!" & LinkCell, _
                ScreenTip:=sName, _
                TextToDisplay:=sName
               AnchorCell.Font.Underline = False
        Else
            'AnchorCell.Interior.ColorIndex = Worksheets(i).Tab.ColorIndex 'colour is a bit off, no colour shade is applied
            AnchorCell.Interior.Color = Worksheets(i).Tab.Color ' this gives better colour
            sName = Sheets(i).Name
               .Hyperlinks.Add _
                Anchor:=AnchorCell, _
                Address:="", _
                SubAddress:="'" & sName & "'!" & LinkCell, _
                ScreenTip:=sName, _
                TextToDisplay:=sName
               AnchorCell.Font.Underline = False
         End If
    End With
Next i
    Dim cell As Range
    For Each cell In Range("B2:B100")
        cell.Font.Color = BorW(cell.Interior.Color)
    Next cell
End Sub