Excel VBA sheet name list with maxing colors

Question

I am trying to write a VBA function where I produce a new sheet, give a lists of all the sheet names in the workbook and match the cell color of the sheet name, with the tab color of the sheet name. The pseudocode will look something like this:

Create a new sheet Loop through all sheets in the workbook Write down the sheet name in the created sheet Retrieve the sheet ThemeColor (e.g. xlThemeColorLight2) Retrieve the sheet TintAndShade (e.g. 0.799981688894314 Set the cell in which the name of the sheet is to the correct ThemeColor and TintAndShade End

Is there a way in which this is possible?

Sub SheetList()

    Dim ws As Worksheet
    Dim x As Integer
    x = 1
    
    Sheets.Add
    sheet_name = InputBox("Please enter a sheet name")
    ActiveSheet.Name = sheet_name                # Create a new sheet name
    
    For Each ws In Worksheets
        Sheets(sheet_name).Cells(x, 1) = ws.Name # Set cell value to sheet name
        
        Dim theme_color As String
        Dim tint_and_shade As Single
    
        theme_color = ...    # Attain sheet ThemeColor of current ws here
        tint_and_shade = ... # Attain sheet TintAndShade of current ws here
    
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = theme_color # Set current cell to theme_color
            .TintAndShade = tint_and_shade # Set current cell to tint_and_shade
            .PatternTintAndShade = 0
        End With
        x = x + 1
Next ws

score 1 · Answer 1 · answered Nov 27 '22 at 17:01

You can use ws.Tab.ThemeColor and ws.Tab.TintAndShade to retrieve those values.

I updated your code so that you can use the wsNewvariable to refer to the new worksheet.

Furthermore I am checking that only color codes of the other worksheets are checked.

Sub SheetList()

    Dim wsNew As Worksheet
    
    With ThisWorkbook.Worksheets
        Set wsNew = .Add(.Item(1))
    End With
    
    Dim sheet_name
    sheet_name = InputBox("Please enter a sheet name")
    wsNew.Name = sheet_name                ' Create a new sheet name
    
    Dim ws As Worksheet, c As Range, x As Long
    For Each ws In Worksheets
        If Not ws Is wsNew Then
            x = x + 1
            Set c = wsNew.Cells(x, 1)
            
            c.Value = ws.Name ' Set cell value to sheet name
            
            Dim theme_color As Single
            Dim tint_and_shade As Single
        
            theme_color = ws.Tab.ThemeColor    ' Attain sheet ThemeColor of current ws here
            tint_and_shade = ws.Tab.TintAndShade ' Attain sheet TintAndShade of current ws here
        
            With c.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                If theme_color > 0 Then
                    .ThemeColor = theme_color ' Set current cell to theme_color
                End If
                .TintAndShade = tint_and_shade ' Set current cell to tint_and_shade
                .PatternTintAndShade = 0
            End With
        End If
    Next ws
End Sub

score 0 · Answer 2 · edited Nov 28 '22 at 01:52

Thanks for your help Ike. I made a full piece of code to get a sheet overview page. It is not the most elegant piece of code, but here it is:

Sub SheetOverview()
'
' SheetOverview
'
    Dim ws As Worksheet
    Dim x As Integer
    Dim c As Range
    
    x = 1
    
    ' Add new sheet, ask user for sheet name
    Sheets.Add
    ActiveWindow.DisplayGridlines = False
    sheet_name = InputBox("Please enter a sheet name")
    ActiveSheet.Name = sheet_name
    
    ' Loop to obtain all sheet names
    For Each ws In Worksheets
        Set c = Sheets(sheet_name).Cells(x, 1)
        
        c.Value = ws.Name
        
        Dim theme_color As Single
        Dim tint_and_shade As Single
    
        theme_color = ws.Tab.ThemeColor    ' Attain sheet ThemeColor of current ws here
        tint_and_shade = ws.Tab.TintAndShade ' Attain sheet TintAndShade of current ws here
    
        With c.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            If theme_color > 0 Then
                .ThemeColor = theme_color  ' Set current cell to theme_color
            End If
            .TintAndShade = tint_and_shade ' Set current cell to tint_and_shade
            .PatternTintAndShade = 0
        End With
        x = x + 1
    Next ws
    
    ' Cut selection
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Cut
    Range("A6").Select
    ActiveSheet.Paste
    
    ' Enter Sheets and Description and format
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "Sheets"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "Description"
    Range("A5:B5").Select
    Selection.Font.Bold = True
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
    ' Format title
    Range("A4").Select
    Selection.End(xlUp).Select
    Selection.Font.Bold = True
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    Selection.Font.Size = 14
    
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Author:"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "[Enter author here]"
    Selection.Font.Italic = True
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Date:"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Selection.Copy
    Range("B3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    Rows("4:4").Select
    Selection.Insert Shift:=xlDown
    Selection.Borders(xlLeft).LineStyle = xlNone
    Selection.Borders(xlRight).LineStyle = xlNone
    Selection.Borders(xlTop).LineStyle = xlNone
    Selection.Borders(xlBottom).LineStyle = xlNone
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Time:"
    
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "=NOW()-TODAY()"
    Range("B4").Select
    Selection.Copy
    Range("B4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    Columns("A:B").Select
    Range("A5").Activate
    Selection.Columns.AutoFit
    Range("B1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    
    Columns("B:B").ColumnWidth = 52.11
    Range("B3:B4").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Range("A1").Select
    
End Sub

If my answer helped you, it would be great if you mark it as answer. Btw I recommend reading [How to avoid using select](https://stackoverflow.com/a/23913882/16578424) - your code will become cleaner :-) — Ike, Nov 28 '22 at 14:18

score 0 · Answer 3 · answered Nov 28 '22 at 18:44

Insert Sheet List

Sub InsertSheetList()
    
    ' Define constants.
    Const Title As String = "Insert Sheet List"
    Const FIRST_CELL As String = "A1"
    Dim Headers() As Variant
    Headers = VBA.Array("Index", "Color", "Name", "Type")

    ' Attempt to reference the workbook.
    Dim wb As Workbook: Set wb = ActiveWorkbook
    If wb Is Nothing Then
        MsgBox "No visible workbooks open.", vbExclamation, Title
        Exit Sub
    End If
    
    ' Input sheet name.
    Dim SheetName As String
    SheetName = InputBox("Please enter a sheet name", Title)
    
    If Len(SheetName) = 0 Then
        MsgBox "Dialog canceled.", vbExclamation
        Exit Sub
    End If
    
    ' Add a worksheet to be the first and reference it.
    wb.Sheets.Add Before:=wb.Sheets(1)
    Dim dws As Worksheet: Set dws = wb.Sheets(1)
    
    ' Attempt to rename the worksheet.
    
    Dim ErrNum As Long
    
    On Error Resume Next
        dws.Name = SheetName
        ErrNum = Err.Number
    On Error GoTo 0
    
    If ErrNum <> 0 Then
        Application.DisplayAlerts = False
            dws.Delete
        Application.DisplayAlerts = True
        MsgBox "Couldn't use '" & SheetName & "' for a sheet name.", _
            vbExclamation, Title
        Exit Sub
    End If
    
    ' Calcuate the number of columns (headers).
    Dim ColumnsCount As Long: ColumnsCount = UBound(Headers) + 1
    
    ' Write the headers.
    Dim drg As Range
    Set drg = dws.Range(FIRST_CELL).Resize(, ColumnsCount)
    drg.Value = Headers
    
    ' Write the list.
    
    Dim sh As Object
    Dim r As Long
    
    For Each sh In wb.Sheets
        r = r + 1
        If r > 1 Then
            Set drg = drg.Offset(1)
            drg.Cells(1).Value = sh.Index
            drg.Cells(2).Interior.Color = sh.Tab.Color
            drg.Cells(3).Value = sh.Name
            drg.Cells(4).Value = TypeName(sh)
        End If
    Next sh
    
    ' Autofit.
    dws.Columns(1).Resize(, ColumnsCount).AutoFit
    
    ' Inform.
    MsgBox "Sheet list created.", vbInformation, Title

End Sub

Excel VBA sheet name list with maxing colors

3 Answers3

Insert Sheet List