Excel VBA sheet name list with maxing colors-CodePudding

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

CodePudding user response：

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

CodePudding user response：

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