VBA Duplicating a sheet then renaming tab, changing tab colour, and adding title based on list of names

myactiondesign

New Member
Joined
Mar 30, 2013
Messages
31
Hey everyone,

I'm looking to create a fresh workbook based off a template for OKR goal tracking every quarter.

I have a list of team names and the below code already works to duplicate the template and create new tabs, change the tab names and change the title of the template to the team name.

VBA Code:
Sub DuplicateTemplate()
    Dim ws As Worksheet, Number As Range
    For Each Code In Sheets("Inputs").Range("A2", Sheets("Inputs").Range("A" & Rows.Count).End(xlUp))
        Sheets("Template").Copy After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Range("A1") = Code
        Worksheets(Worksheets.Count).Range("B1") = Code.Offset(, 1)
        Worksheets(Worksheets.Count).Name = Code.Offset(, 1)
    Next Code
End Sub

This reads from a table like this:

CodeNames
1Sample team name
2Another sample team name

Where I'm struggling is to also change the colour of the tab based on the team name.

What I'd like to do is have a third column with an RGB colour and have the tab colour changed when created.

Can anyone help? Much appreciated and thanks in advance for your time!

Thank you!
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Rather than putting the RGB value in a cell, change the cell fill colour & you could use
VBA Code:
Sub DuplicateTemplate()
    Dim ws As Worksheet, Number As Range
    For Each Code In Sheets("Inputs").Range("A2", Sheets("Inputs").Range("A" & Rows.Count).End(xlUp))
        Sheets("Template").Copy After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Range("A1") = Code
        Worksheets(Worksheets.Count).Range("B1") = Code.Offset(, 1)
        Worksheets(Worksheets.Count).Name = Code.Offset(, 1)
        Worksheets(Worksheets.Count).Tab.Color = Code.Offset(, 1).Interior.Color
    Next Code
End Sub
 
Upvote 0
Solution
Another method :

VBA Code:
Option Explicit

Sub DoesTheSheetExists()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheet
      
Application.ScreenUpdating = False
    
Set MyRange = Sheets("Inputs").Range("A1")
Set MyRange = Range(Range("A2"), MyRange.End(xlDown))
    
    For Each MyCell In MyRange
         If SheetExist(MyCell.Value) Then
            GoTo FindNext:
        Else
            Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
            Sheets(Sheets.Count).Name = MyCell.Offset(0, 1).Value ' renames the new worksheet
            Sheets(Sheets.Count).Range("A1").Value = MyCell.Value
            Sheets(Sheets.Count).Range("B1").Value = MyCell.Offset(0, 1).Value
            Sheets(Sheets.Count).Tab.ColorIndex = MyCell.Offset(0, 2).Value
        End If
FindNext:
    Next MyCell
      
    Application.ScreenUpdating = True
    Sheets("Inputs").Activate
    Sheets("Inputs").Range("A1").Select
    
  
End Sub

 

Function SheetExist(strSheetName As String) As Boolean
    Dim i As Integer

    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = strSheetName Then
            SheetExist = True
            Exit Function
        End If
    Next i
End Function


Download workbook : Create New Tabs From List, Rename Tab and Color Code.xlsm
 
Upvote 0
Rather than putting the RGB value in a cell, change the cell fill colour & you could use
VBA Code:
Sub DuplicateTemplate()
    Dim ws As Worksheet, Number As Range
    For Each Code In Sheets("Inputs").Range("A2", Sheets("Inputs").Range("A" & Rows.Count).End(xlUp))
        Sheets("Template").Copy After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Range("A1") = Code
        Worksheets(Worksheets.Count).Range("B1") = Code.Offset(, 1)
        Worksheets(Worksheets.Count).Name = Code.Offset(, 1)
        Worksheets(Worksheets.Count).Tab.Color = Code.Offset(, 1).Interior.Color
    Next Code
End Sub
Thank you so much, that worked an absolute treat! :)
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,254
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top