OzGrid

How to copy a sheet and rename from a list, ignore duplicates

Requirement:

The user has an excel macro that is duplicating a template and renaming the tabs from a list. What the user would like, is to be able to run the macro more than once (i.e. if someone adds to the list) without getting a bug error. So, the user needs to add to this macro to tell excel to just overlook the duplicates and keep going until it gets to the next unique name.

The list the user is using is on a tab called "Opportunity Pipeline" in column A. The tab the user would like to copy and rename is called "Template" - the "Template" is hidden so the user also needs the code to unhide the template, copy it, rename it (multiple times) and then hide it again.

Here is the user's code:

Sub CreateSheetsFromAList()
Dim MyCell, MyRange As Range
Set MyRange = Sheets("Opportunity Pipeline").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Sheets("Template").Visible = True
For Each MyCell In MyRange
    Sheets("Template").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = MyCell.Value ' renames the new worksheet
   
Next MyCell
Sheets("Template").Visible = False
End Sub

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/147684-copy-sheet-and-rename-from-a-list-ignore-duplicates

Solution:

Sub CreateSheetsFromAList() ' Example Add Worksheets with Unique Names
    Dim MyRange As Range 
    Dim dic As Object, c As Range 
    Dim k As Variant, tmp As String 
     
    Set dic = CreateObject("scripting.dictionary") 
    Set MyRange = Sheets("Schedule").Range("A11") 
    Set MyRange = Range(MyRange, MyRange.End(xlDown)) 
    Sheets("Template").Visible = True 
     
    For Each c In MyRange
        ' Test the range to make sure to only deal with non-empty cells .... ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If c <> "" Then 
          tmp = Trim(c.Value) 
          If Len(tmp) > 0 Then dic(tmp) = dic(tmp) + 1
        End If 
    Next c 
     
    For Each k In dic.keys 
        If Not WorksheetExists(k) Then 
            Sheets("Template").Copy After:=Sheets(Sheets.Count) 
            ActiveSheet.Name = k ' renames the new worksheet
        End If 
    Next k 
     
    Sheets("Template").Visible = False 
End Sub 
 
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean 
    On Error Resume Next 
    WorksheetExists = (Sheets(WorksheetName).Name <> "") 
    On Error Goto 0 
End Function

Obtained from the OzGrid Help Forum.

Solution provided by Carim.

See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets

See also:

Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.

Gallery