Automation of Tabs

D

Danny54

Active Member
Joined
Jul 3, 2019
Messages
295
Office Version
  1. 365
Platform
  1. Windows
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

1696974028984.png


New workbook showing contents of Red Tab

1696974104240.png



same workbook showing Blue Tab

1696974184099.png




Any help would be appreciated.


Thanks
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
You said:
New workbook showing contents of Red Tab
do you really mean new "Workbook"? or do you mean new "Worksheet" ?
 
Upvote 0
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.

VBA Code: 
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
 
Last edited:
Upvote 1
kevin9999 said:
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.

VBA Code: 
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
Click to expand...
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
 
Upvote 0
kevin9999 said:
Happy to help Danny, and thanks for the feedback 👍
Click to expand...
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
 
Upvote 0
Danny54 said:
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
Click to expand...

Here's how the new input sheet looks

1697051667787.png
 
Upvote 0
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:
VBA Code: 
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
 
Upvote 0
Solution
kevin9999 said:
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:
VBA Code: 
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
Click to expand...

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. :)
 
Upvote 0
@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
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
Copy Multiple Tabs to a new workbook
Replies
9
Views
355
skillilea
S
M
  • Question
Need to produce a couple workbooks..
Replies
5
Views
84
awoohaw
awoohaw
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
248
Insurance Dave
I
L
  • Question
Step 1: Can you Loop Through Multiple Excel worksheets in one workbook (Copy and paste all to new worksheet or Workbook)
Replies
9
Views
416
Micron
M
L
  • Question
Trying to determine if something is possible.
Replies
1
Views
147
frabulator
frabulator

Forum statistics

Threads
1,215,073
Messages
6,122,976
Members
449,095
Latest member
Mr Hughes

Share this page

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