Macro to autogenerate sheets based on unique values of a list

[Closed]
Report
Posts
1
Registration date
Sunday August 16, 2015
Status
Member
Last seen
August 16, 2015
-
Posts
2809
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 23, 2021
-
Hello!

I would greatly appreciate if anyone could help me with a macro. I have a number of populated rows in one sheet (Sheet A) and one of the columns contains a drop-down list. Now, I would like a macro to autogenerate sheets with the names of each sheet corresponding to the name on the list. HOWEVER, the catch is that the column in sheet A will end up with a couple of rows with duplicate names. In other words, if we consider the column to be J, J12 might be named 'Pipes', J13 could be 'Plates', and J14 could again be 'Pipes'.

Now, how do you think the following code could be tweaked in such a way that the macro gets executed without a hitch?

Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("SheetA").Range("J12")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub

Thanks a lot for your help on this.

BR,
Hack

1 reply

Posts
2809
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
September 23, 2021
484
Hi Hack,

The code below will check if the sheet name is already applied. If so then delete the unnamed sheet and continue loop.

Here is the amended code:
Sub CreateSheetsFromAList()
Dim MyCell, MyRange As Range
Dim DeleteSh As Boolean
Dim sh As Worksheet

Set MyRange = Sheets("SheetA").Range("J12")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange
    Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
    For Each sh In Worksheets
        If sh.Name = MyCell.Value Then DeleteSh = True
    Next sh
    If DeleteSh = True Then
        Application.DisplayAlerts = False
        ActiveSheet.Delete
        Application.DisplayAlerts = True
    Else:
        Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
    End If
    DeleteSh = False
Next MyCell

End Sub


Best regards,
Trowa

Monday, Tuesday and Thursday are usually the days I'll respond. Bear this in mind when awaiting a reply.