Creating multiple sheets automatically

[Noxqss38242]

Need to create 350 sheets based on data in column J

 

[davesexcel]

What kind of data do you have in column J?

 

[Noxqss38242]

What kind of data do you have in column J?

City, state
Ex: Robers, WI
Laredo, TX
Nashville, TN

 

[Noxqss38242]

Some are repeated because there is more than 1 location in the city but I still need a seperate sheet for each time. So, I will need (2) Carson, CA sheets and, etc...

 

[My Aswer Is This]

So are you saying you want a script to run and.
Look in each cell in column J and create a new sheet named the value in column J

So if J1 has Alpha you want a new sheet added to your workbook named Alpha
And if J2 has Bravo you want a new sheet added to your workbook named Bravo

And what is the name of the sheet with all these values in column J

And you cannot have two sheets with the same name.

 

[Noxqss38242]

I can work around the double name by changing it up a bit, but yes, if J2 says Alpha, sheeta 1 to say Alpha, etc... just like you described

 

[Fluff]

How about

Sub AddSheets()
   Dim cl As Range
   Dim Ky As Variant
   Dim i As Long
   
   With CreateObject("Scripting.dictionary")
      For Each cl In Range("J2", Range("J" & Rows.Count).End(xlUp))
         .Item(cl.Value) = .Item(cl.Value) + 1
      Next cl
      For Each Ky In .keys
         If .Item(Ky) = 1 Then
            Sheets.Add.name = Ky
         Else
            For i = 1 To .Item(Ky)
               Sheets.Add.name = Ky & " (" & i & ")"
            Next i
         End If
      Next Ky
   End With
End Sub

 

[My Aswer Is This]

Well I guess Fluff has now provide a answer.

 

[davesexcel]

If the worksheet exists, then you can copy the first sheet with that name, then it will automatically index it with sheetname(2),sheetname(3), if the sheet does not exist, then it will add a new sheet and name it.
This example will assume the data is in column J, Sheet1

Sub AddSheets()
    Dim rng As Range, c As Range, LstRw As Long, sh As Worksheet
    Dim worksh As Integer
    Dim worksheetexists As Boolean

    Set sh = Sheets("Sheet1")

    With sh
        LstRw = .Cells(.Rows.Count, "J").End(xlUp).Row
        Set rng = .Range("J2:J" & LstRw)
    End With

    Application.ScreenUpdating = False

    For Each c In rng.Cells
        worksh = Application.Sheets.Count
        worksheetexists = False
        For x = 1 To worksh
            If Worksheets(x).Name = c Then
                worksheetexists = True
                Sheets(c.Value).Copy After:=Worksheets(Sheets.Count)
                'MsgBox c & ", already Exists"
                Exit For
            End If
        Next x
        If worksheetexists = False Then
            'MsgBox "Nope"
            Sheets.Add After:=Worksheets(Sheets.Count)
            ActiveSheet.Name = c
        End If

    Next c

    sh.Select


End Sub

Just for convenience, here is a code to delete all the sheet except sheet1

Sub DeleteShts()
    Dim sh As Worksheet
    Application.DisplayAlerts = False
    For Each sh In Sheets
        If sh.Name <> "Sheet1" Then sh.Delete
    Next sh
End Sub

 

[Noxqss38242]

Thanks all!