Automation of Tabs

[Danny54]

Good Afternoon

is it possible to automatically create tabs from text in a xls book and populate the new tab with data split by comma using the colors column?

From this master sheet containing data, I need to create unique tabs based on color. I'm thinking of pressing a button and a macro runs against column C(Colors) to create the unique tabs show in workbook 2. There would be a tab for each new color showing all rows from the master containing that color.

Workbook 1

New workbook showing contents of Red Tab

same workbook showing Blue Tab

Any help would be appreciated.


Thanks

 

[My Aswer Is This]

You said:
New workbook showing contents of Red Tab
do you really mean new "Workbook"? or do you mean new "Worksheet" ?

 

[kevin9999]

Please try the following on a copy of your workbook. It's a bit long-winded, but may suffice until a more elegant solution comes along. Make sure you copy the Function as well as the sub.
EDITED.

Option Explicit
Sub Danny54()
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Master")
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    Dim r As Range, c As Range, s As String, col, i As Long, a
    Set r = ws1.Range("C2:C" & ws1.Cells(Rows.Count, "C").End(xlUp).Row)
    
    'Get list of unique colors
    With CreateObject("scripting.dictionary")
        .CompareMode = 1
        For Each c In r
            For Each col In Split(c, ",")
                .Item(Trim(col)) = Empty
            Next col
        Next c
        a = Application.Transpose(.keys)
        .RemoveAll
    End With
    
    'Check if sheet exists - if yes, clear & copy new data, if no, create new sheet
    For i = LBound(a) To UBound(a)
        s = a(i, 1)
        If WorksheetExists(s) Then
            Set ws = Worksheets(s)
            With ws.Range("A1").CurrentRegion
                .Offset(1).ClearContents
                With ws1.Range("A1").CurrentRegion
                    .AutoFilter 3, "*" & s & "*"
                    .Offset(1).Resize(.Rows.Count - 1).Copy ws.Range("A2")
                    .AutoFilter
                End With
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        Else
            ws1.Copy after:=Worksheets(Worksheets.Count)
            Set ws = ActiveSheet
            ws.Name = s
            With ws.Range("A1").CurrentRegion
                .AutoFilter 3, "<>*" & s & "*"
                .Offset(1).EntireRow.Delete
                .AutoFilter
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        End If
    Next i
End Sub
Function WorksheetExists(s As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & s & "'!A1)")
End Function

 

[Danny54]

Please try the following on a copy of your workbook. It's a bit long-winded, but may suffice until a more elegant solution comes along. Make sure you copy the Function as well as the sub.
EDITED.

Option Explicit
Sub Danny54()
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Master")
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    Dim r As Range, c As Range, s As String, col, i As Long, a
    Set r = ws1.Range("C2:C" & ws1.Cells(Rows.Count, "C").End(xlUp).Row)
   
    'Get list of unique colors
    With CreateObject("scripting.dictionary")
        .CompareMode = 1
        For Each c In r
            For Each col In Split(c, ",")
                .Item(Trim(col)) = Empty
            Next col
        Next c
        a = Application.Transpose(.keys)
        .RemoveAll
    End With
   
    'Check if sheet exists - if yes, clear & copy new data, if no, create new sheet
    For i = LBound(a) To UBound(a)
        s = a(i, 1)
        If WorksheetExists(s) Then
            Set ws = Worksheets(s)
            With ws.Range("A1").CurrentRegion
                .Offset(1).ClearContents
                With ws1.Range("A1").CurrentRegion
                    .AutoFilter 3, "*" & s & "*"
                    .Offset(1).Resize(.Rows.Count - 1).Copy ws.Range("A2")
                    .AutoFilter
                End With
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        Else
            ws1.Copy after:=Worksheets(Worksheets.Count)
            Set ws = ActiveSheet
            ws.Name = s
            With ws.Range("A1").CurrentRegion
                .AutoFilter 3, "<>*" & s & "*"
                .Offset(1).EntireRow.Delete
                .AutoFilter
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        End If
    Next i
End Sub
Function WorksheetExists(s As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & s & "'!A1)")
End Function

Thanks so much for the solution. I tried it this morning and it provided exactly what was needed to split out the values. I enjoyed following your code based on its logic which shows how to break the solution into several steps. Again - Thanks

 

[kevin9999]

Happy to help Danny, and thanks for the feedback

 

[Danny54]

Happy to help Danny, and thanks for the feedback

Kevin9999,

adapting the macro you supplied to another spreadsheet, I have a question. What's the best way to go about limiting the tab name length being created as some of them exceed the 30 char max length causing the macro to stop. On the adapted sheet using your macro, I find that my column c has comma delimited values greater than 30 chars and when the macro tries to create a tab using this value its abends. I'm also, finding that the data being split by comma contains slashes and colons which tab names can't use. Thinking of creating a edit in the first step to shorten the name and replace characters that are not permitted in tab names. Thoughts?

Again, Thanks

 

[Danny54]

Kevin9999,

adapting the macro you supplied to another spreadsheet, I have a question. What's the best way to go about limiting the tab name length being created as some of them exceed the 30 char max length causing the macro to stop. On the adapted sheet using your macro, I find that my column c has comma delimited values greater than 30 chars and when the macro tries to create a tab using this value its abends. I'm also, finding that the data being split by comma contains slashes and colons which tab names can't use. Thinking of creating a edit in the first step to shorten the name and replace characters that are not permitted in tab names. Thoughts?

Again, Thanks

Here's how the new input sheet looks

 

[kevin9999]

That's a significant addition to your original post and perhaps warrants a new thread, or better still, should have been mentioned initially. However, on this occasion, please try the following code on a copy of your workbook:

Option Explicit
Sub Danny54_V2()
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Master")
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    Dim r As Range, c As Range, s As String, col, i As Long, a, x
    Set r = ws1.Range("C2:C" & ws1.Cells(Rows.Count, "C").End(xlUp).Row)
    Dim scrub
    scrub = Array("/", "\", "?", "*", ":", "[", "]")
    
    'Get list of unique colors
    With CreateObject("scripting.dictionary")
        .CompareMode = 1
        For Each c In r
            For Each col In Split(c, ",")
                .Item(Trim(col)) = Empty
            Next col
        Next c
        a = Application.Transpose(.keys)
        .RemoveAll
    End With
    
    'Check if sheet exists - if yes, clear & copy new data, if no, create new sheet
    For i = LBound(a) To UBound(a)
        s = a(i, 1)
        For Each x In scrub
                s = Replace(s, x, " ")
            Next x
            s = VBA.Trim(Left(s, 30))
        If WorksheetExists(s) Then
            Set ws = Worksheets(s)
            With ws.Range("A1").CurrentRegion
                .Offset(1).ClearContents
                With ws1.Range("A1").CurrentRegion
                    .AutoFilter 3, "*" & s & "*"
                    .Offset(1).Resize(.Rows.Count - 1).Copy ws.Range("A2")
                    .AutoFilter
                End With
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        Else
            ws1.Copy after:=Worksheets(Worksheets.Count)
            Set ws = ActiveSheet
            ws.Name = s
            With ws.Range("A1").CurrentRegion
                .AutoFilter 3, "<>*" & s & "*"
                .Offset(1).EntireRow.Delete
                .AutoFilter
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        End If
    Next i
End Sub
Function WorksheetExists(s As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & s & "'!A1)")
End Function

 

[Danny54]

That's a significant addition to your original post and perhaps warrants a new thread, or better still, should have been mentioned initially. However, on this occasion, please try the following code on a copy of your workbook:

Option Explicit
Sub Danny54_V2()
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Master")
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    Dim r As Range, c As Range, s As String, col, i As Long, a, x
    Set r = ws1.Range("C2:C" & ws1.Cells(Rows.Count, "C").End(xlUp).Row)
    Dim scrub
    scrub = Array("/", "\", "?", "*", ":", "[", "]")
   
    'Get list of unique colors
    With CreateObject("scripting.dictionary")
        .CompareMode = 1
        For Each c In r
            For Each col In Split(c, ",")
                .Item(Trim(col)) = Empty
            Next col
        Next c
        a = Application.Transpose(.keys)
        .RemoveAll
    End With
   
    'Check if sheet exists - if yes, clear & copy new data, if no, create new sheet
    For i = LBound(a) To UBound(a)
        s = a(i, 1)
        For Each x In scrub
                s = Replace(s, x, " ")
            Next x
            s = VBA.Trim(Left(s, 30))
        If WorksheetExists(s) Then
            Set ws = Worksheets(s)
            With ws.Range("A1").CurrentRegion
                .Offset(1).ClearContents
                With ws1.Range("A1").CurrentRegion
                    .AutoFilter 3, "*" & s & "*"
                    .Offset(1).Resize(.Rows.Count - 1).Copy ws.Range("A2")
                    .AutoFilter
                End With
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        Else
            ws1.Copy after:=Worksheets(Worksheets.Count)
            Set ws = ActiveSheet
            ws.Name = s
            With ws.Range("A1").CurrentRegion
                .AutoFilter 3, "<>*" & s & "*"
                .Offset(1).EntireRow.Delete
                .AutoFilter
                .Range("C2:C" & .Cells(Rows.Count, "A").End(xlUp).Row).Value = s
            End With
        End If
    Next i
End Sub
Function WorksheetExists(s As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & s & "'!A1)")
End Function

Thanks for the assistance. When I originally did the ask, I was only using it for one type of input but since it worked so slick, I thought I would try to use it on the second type of input. It worked like a champ. I really appreciate your help. I did learn several things that I can use in the future.

 

[Fluff]

@Danny54 in future please mark the post that contains the solution, rather than your post saying it works. I have changed it for you this time.
Thanks