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

sachavez

Active Member
Joined
May 22, 2009
Messages
446
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

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

Repush

Board Regular
Joined
Sep 21, 2015
Messages
133
Office Version
  1. 365
Platform
  1. Windows
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
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
3,789
Office Version
  1. 365
Platform
  1. Windows
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]
 

sachavez

Active Member
Joined
May 22, 2009
Messages
446
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
 

sachavez

Active Member
Joined
May 22, 2009
Messages
446

ADVERTISEMENT

Thanks. Trying to make these work.

Steve
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
73,269
Office Version
  1. 365
Platform
  1. Windows
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
 

sachavez

Active Member
Joined
May 22, 2009
Messages
446

ADVERTISEMENT

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
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
3,789
Office Version
  1. 365
Platform
  1. Windows
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:
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,220
Messages
5,836,067
Members
430,404
Latest member
goncaloColt

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
Top