Tab color based on list

[zakasnak]

Could I color the tabs based on a list in a sheet?

I have a breakout code that breaks out a sheet into multiples:

Sub CopyToNewSheetsByGroup2()
Dim strName As String, i As Integer
Dim UsedRng As Range, rng As Range, FRng As Range, R As Range, c As Range, sh As Worksheet
Dim HdrBoo As Boolean, HdrMsg As Variant, HdrRng As Range
Dim StartTime As Date, TmpSh As Worksheet, TmpRng As Range
Dim GroupIDs As String, ShName As String
 
    intResponse = MsgBox("This macro will create a worksheet for each unique group identifier" & vbCrLf & _
    "in the user-selected column. This may take a while to" & vbCrLf & _
    "process if there are a lot of groups. Continue?", vbOKCancel, "Separate By Groups")
 
    If intResponse = vbOK Then
        'Get used range for the sort
        Set UsedRng = ActiveSheet.UsedRange
 
        'Ask for column to base your search. If no range is selected procedure stopped
        On Error Resume Next 'set Rng will error if no range selected
        Set rng = Application.InputBox("Select column with Group ID's" & vbCrLf _
        & "Column must not contain Formulas.", "Pick a Column", , , , , , 8)
        If rng Is Nothing Or rng.Columns.Count > 1 Then 'exit if cancel was pressed or more than 1 column is selected
            MsgBox "Operation cancelled"
            Exit Sub
        End If
 
        'Ask if theres a header row. By default HdrBoo is false.
        HdrMsg = MsgBox("Do you have a header row?" & vbLf & _
            "Note: Must be the 1st row in worksheet", vbYesNo, "Header Row?")
        If HdrMsg = vbYes Then
            HdrBoo = True 'variable to indicate if a header is used
        End If
 
        'Start Timer
        StartTime = Timer
 
        'Turn off screen updating & calculation
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
 
        On Error GoTo errorhandler
        'Filter unique values
        ActiveSheet.Columns(rng.Column).AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=rng, Unique:=True
 
        'Copy unique values to a temporary sheet
        Set TmpSh = Worksheets.Add 'create temp sheet
        Sheets(rng.Parent.name).Activate 'return to original sheet
        Set rng = Range(rng.End(xlUp), rng.End(xlDown)) 'make sure entire column is selected
 
        rng.Copy TmpSh.Range("a1") 'copy unique items to temporary sheet
        TmpSh.Activate
        MyCount = TmpSh.Range([A1], [A1].End(xlDown)).Rows.Count
 
        If MyCount > 51 Then
            intResponse = MsgBox("There are more than 50 different groups." & vbCrLf & vbCrLf & _
            "This could take a while. Continue?", vbOKCancel, "Separate by Groups")
            If intResponse = vbCancel Then GoTo errorhandler
        End If
 
        'Set ranges for header (if applicable) and unique values
        TmpSh.Activate
        If HdrBoo = True Then
            Set HdrRng = Range("A1") '1st row in the range is the header
            Set TmpRng = Range("A2:A" & Range("A1").End(xlDown).Row) 'unique values
        Else
            Set TmpRng = Range("A1:A" & Range("A1").End(xlDown).Row) 'unique values
        End If
 
        Sheets(rng.Parent.name).Activate 'return to original sheet
        Application.CutCopyMode = False 'turn off copy mode
        ActiveSheet.ShowAllData 'remove Advanced Filter
        Set FRng = Range(rng.End(xlUp), rng.End(xlDown)) 'Set Full Range column for later use
 
        'Loop through each unique value to copy row to target in respective new sheets
        For Each c In TmpRng
            i = i + 1 'counter for sheet name
            Set sh = Worksheets.Add(After:=Sheets(Sheets.Count)) 'add a new sheet & name it
            ShName = TrimExcelSheetName(c.Value)
            If SheetExists(ShName) Then
                sh.name = ShName & Sheets.Count
            Else
                sh.name = ShName 'name sheet as string and counter number
            End If
            'Assign counter variable for row number to copy to
            'Also copy Header if True
            If HdrBoo = True Then
                cntr = Sheets(ShName).UsedRange.Rows.Count + 1
                'copy header row to target sheet
                Sheets(rng.Parent.name).Rows("1:1").Copy Sheets(ShName).Range("A1")
            Else
                cntr = Sheets(ShName).UsedRange.Rows.Count
            End If
            For Each R In FRng
                If R.Value = c Then
                    r2c = R.Row
                    Sheets(rng.Parent.name).Rows(r2c & ":" & r2c).Copy Sheets(ShName).Range("A" & cntr)
                    cntr = cntr + 1 'increment counter row number
                End If
            Next R
            sh.Cells.EntireColumn.AutoFit
            ActiveWindow.Zoom = 85
        Next c
 
        'Turn back on screen updating & remove filter
        Application.ScreenUpdating = True
        Sheets(rng.Parent.name).Activate 'return to original sheet
        ActiveSheet.AutoFilterMode = False
 
        'Delete Temporary sheet
        Application.DisplayAlerts = False 'avoids delete confirmation message
        TmpSh.Delete
        Application.DisplayAlerts = True
 
        'Display the elapsed time
        MsgBox "The procedure took  " & Format(Timer - StartTime, "00.00") & "  seconds.", _
            vbInformation, "Operation Successfully Completed"
        End If
        ActiveSheet.AutoFilterMode = False
errorhandler:
    If Err <> 0 Then
        MsgBox Err.Number & ": " & Err.Description, , "Error Occurred"
        On Error GoTo 0
    End If
    Application.Calculation = xlCalculationAutomatic
 
    ActiveWindow.TabRatio = 0.962
    Call SortSheets
End Sub

After this, in a separate macro, I would like to color these named tabs as shown:

Index sheet

<TABLE style="PADDING-RIGHT: 2pt; PADDING-LEFT: 2pt; FONT-SIZE: 10pt; FONT-FAMILY: Arial,Arial; BACKGROUND-COLOR: #ffffff" cellSpacing=0 cellPadding=0 border=1><COLGROUP><COL style="FONT-WEIGHT: bold; WIDTH: 30px"><COL style="WIDTH: 259px"></COLGROUP><TBODY><TR style="FONT-WEIGHT: bold; FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center"><TD></TD><TD>A</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">1</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #ff9900">ADA - MANUFACTURER ONLY</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">2</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #ff9900">ADA-WEA MANUFACTURER ONLY</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">3</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">E1 ENTERTAINMENT DISTRIBUTION</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">4</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">EMI DISTRIBUTION -</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">5</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">IMAGE ENTERTAINMENT -</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">6</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">RED DISTRIBUTION</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">7</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #ff9900">SMITH MUSIC GROUP</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">8</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">SONY MUSIC</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">9</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">UMGD - UNIVERSAL MUSIC GROUP D</TD></TR><TR style="HEIGHT: 17px"><TD style="FONT-SIZE: 8pt; BACKGROUND-COLOR: #cacaca; TEXT-ALIGN: center">10</TD><TD style="FONT-FAMILY: Calibri; BACKGROUND-COLOR: #99cc00">WEA</TD></TR></TBODY></TABLE>

Excel tables to the web >> http://www.excel-jeanie-html.de/index.php?f=1" target="_blank"> Excel Jeanie HTML 4