VBA: Create new sheet name based on unique names in column K

sachavez

Active Member
Joined
May 22, 2009
Messages
469
Hello,

Looking for a VBA solution that will look for unique names in column K and then create a new sheet for each name. My data set varies each week, and I am using UR = Activesheet.Usedrange.Rows.Count to determine the number of rows in the data set. I have a header row, which does not need a new tab name.

Thanks in advance.

Steve
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
part one:
Code:
Sub SheetsFromRange()
    Dim Start As Range, c As Range
    Set Start = ActiveSheet.Range("A1").CurrentRegion
    For Each c In Start
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Name = c.Value
    Next c
End Sub
part two:
Code:
Sub UniqueSort()
    Dim UList, i As Long
    UList = ActiveCell.CurrentRegion.Columns(1)
    With CreateObject("System.Collections.ArrayList")
        For i = 1 To UBound(UList)
            If UList(i, 1) <> "" And Not .contains(UList(i, 1)) Then .Add UList(i, 1)
        Next i
        .Sort
        ActiveCell.Offset(, 3).Resize(.Count) = Application.Transpose(.toarray)
    End With
End Sub
It's up to you to combine and tweak
 
Upvote 0
Try this:

Code:
[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] a1090800b()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1090800-vba-create-new-sheet-name-based-unique-names-column-k.html[/COLOR][/I]

[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] va
[COLOR=Royalblue]Dim[/COLOR] d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] ws [COLOR=Royalblue]As[/COLOR] Worksheet

Application.ScreenUpdating = [COLOR=Royalblue]False[/COLOR]
[COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=brown]"scripting.dictionary"[/COLOR])
d.CompareMode = vbTextCompare
    [COLOR=Royalblue]For[/COLOR] [COLOR=Royalblue]Each[/COLOR] ws [COLOR=Royalblue]In[/COLOR] ActiveWorkbook.Worksheets
    d(ws.Name) = [COLOR=brown]""[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]

va = Range([COLOR=brown]"K2"[/COLOR], Cells(Rows.count, [COLOR=brown]"K"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
        [COLOR=Royalblue]If[/COLOR] [COLOR=Royalblue]Not[/COLOR] d.Exists(va(i, [COLOR=crimson]1[/COLOR])) [COLOR=Royalblue]Then[/COLOR]
        Sheets.Add(After:=Worksheets(Worksheets.count)).Name = va(i, [COLOR=crimson]1[/COLOR])
        [COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]If[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]
Application.ScreenUpdating = [COLOR=Royalblue]True[/COLOR]
[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]
 
Upvote 0
Thank you, Akuini. This generated 824 tabs, which is the number of rows in my data set. In the data set, I should only have 6 unique names.

Steve
 
Upvote 0
Another option
Code:
Sub sachavez()
   Dim Cl As Range
   
   For Each Cl In Range("K2", Range("K" & Rows.Count).End(xlUp))
      If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
         Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
      End If
   Next Cl
End Sub
 
Upvote 0
Fluff. BINGO. Thank you so much! Problem solved!!!

Another option
Code:
Sub sachavez()
   Dim Cl As Range
   
   For Each Cl In Range("K2", Range("K" & Rows.Count).End(xlUp))
      If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
         Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
      End If
   Next Cl
End Sub
 
Upvote 0
Thank you, Akuini. This generated 824 tabs, which is the number of rows in my data set. In the data set, I should only have 6 unique names.

Steve

Hm, I don't understand, it worked for me. The list is in col K, isn't it?

Edit: Ah, you're right I forget to add the new value to the dictionary.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,207
Members
448,554
Latest member
Gleisner2

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