Create a distinct worksheet for each unique value in the column named "Fruit"

[VBAProIWish]

Hello All,

I have a workbook that I download that contains a worksheet that has a varying amount of rows each time I download it.

Sometimes I can have 10 rows, while other times, I can have 80 rows. This worksheet has a column named "Fruit" and the number and kind of fruits can vary. There is also no master list of these fruits. New fruits can be added at any time, so a lookup list would not work in this scenario.

What I need is code that will create a new worksheet for each unique fruit in the fruits column, deleting all fruits except for that one unique fruit.

Note that there are usually no more than 20 unique fruits every time I download the workbook but this can vary.


Here's an example...
1. I download my usual workbook.
2. This particular time, there happens to be 6 unique fruits.
3. There are 21 rows in this download (Title row + 20 rows of data).



4 fruits each have values in 3 rows (12 rows total)
2 fruits each have values in 4 rows ( 8 rows total)

This is a total of 6 unique fruits. Therefore, in addition to the original worksheet, 6 additional worksheets should be created.



For example, let's say I have...
1. Banana - In 3 rows in the "Fruit" column
2. Grape - In 3 rows in the "Fruit" column
3. Cherry - In 3 rows in the "Fruit" column
4. Apple - In 3 rows in the "Fruit" column

5. Pineapple - In 4 rows in the "Fruit" column
6. Coconut - In 4 rows in the "Fruit" column



While keeping the original worksheet, 6 new distinct worksheets would be created (using each fruit as the worksheet name) with only those fruits, deleting all other rows with non-matching fruit (except the title row)

1. A "Banana" worksheet with 3 rows (+ Title row)
2. A "Grape" worksheet with 3 rows (+ Title row)
3. A "Cherry" worksheet with 3 rows (+ Title row)
4. A "Coconut" worksheet with 3 rows (+ Title row)

5. A "Pineapple" worksheet with 4 rows (+ Title row)
6. A "Coconut" worksheet with 4 rows (+ Title row)

I hope I explained this well enough. Please ask if there are any questions at all.

Thanks much to anyone who can help me with this!

 

[VBAProIWish]

Thanks for the attempt, but no, I would like the worksheet color to remain the same, not a cell.

Also, as far as the column widths and row heights, I thought I had it figured out, by using the code below, but it only formatted the first newly created worksheet and not any additional ones.

You know what?, Let's assume that I DO NOT have varying column widths and row heights. If you could provide code for that and code to keep the color of the newly created worksheets the same as the source worksheet, that would be fantastic!

Again, thanks so much for your help; much appreciated!



Here is the code I used to copy the column widths, but only worked on the first newly created worksheet

Sheets("Main").Columns("A:AN").Copy


    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select


Selection.PasteSpecial Paste:=xlPasteColumnWidths

 

[Fluff]

This will set columns to be the same width as col A & the row height to be the same as row2. Also the new sheet will be the same colour as A1.
All values taken from the original sheet.

Sub CheckMove()

    Dim Dict As Object
    Dim Rng As Range
    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim Ky As Variant
    Dim FCol As Long
    Dim PCol As Long
    Dim UsdCols As Long
    Dim ClWdth As Long
    Dim RwHght As Long

Application.ScreenUpdating = False
    
    Set Ws = ActiveSheet
    With Ws
        UsdCols = .Cells(1, .Columns.Count).End(xlToLeft).Column
        FCol = .Rows(1).Find("Fruit").Column
        PCol = .Rows(1).Find("Person").Column
        UsdRws = .Cells(Rows.Count, FCol).End(xlUp).Row
        ClWdth = .[COLOR=#ff0000]Columns(1)[/COLOR].ColumnWidth
        RwHght = [COLOR=#ff0000].Rows(2)[/COLOR].RowHeight
    End With
    
    Set Dict = CreateObject("scripting.dictionary")
    
    For Each Rng In Ws.Range(Ws.Cells(2, FCol), Ws.Cells(UsdRws, FCol))
        Dict(Rng.Text) = Ws.Cells(Rng.Row, PCol)
    Next Rng

    For Each Ky In Dict.keys
        Sheets.Add(after:=Ws).Name = Dict(Ky) & " - " & Ky
        With Ws.Range("A1")
            .AutoFilter field:=FCol, Criteria1:=Ky
            .Range(.Cells(1, 1), .Cells(UsdRws, UsdCols)).SpecialCells(xlCellTypeVisible).Copy Range("A1")
            Cells.Interior.Color = [COLOR=#ff0000].Range("A1")[/COLOR].Interior.Color
            Cells.RowHeight = RwHght
            Cells.ColumnWidth = ClWdth
        End With
    Next Ky
    Ws.Activate
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub

 

[VBAProIWish]

So, here's where we are at

This new code is making all the cells in the entire worksheet to be one color, and it's based on the color of a cell. I don't want to change the color of any cells, I want to change the color of the worksheet "TABS". Sorry if I explained this incorrectly.

This new code is making the column widths all the same based on the column width in column A. I want to simply copy all the column widths from a worksheet named "Main", to all the newly created "Fruit" worksheets.

This code here does that, but only for the first fruit worksheet, not any additional ones...

Sheets("Main").Columns("A:AN").Copy
Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths

Issue 1 - Column Widths for all new sheets for each fruit

Can you PasteSpecial to the newly created worksheets -
The column widths (from columns A to AN) from a worksheet I have named "main" to the newly created worksheets?



Issue 2 - Row heights for all new sheets for each fruit

Can you make the newly created worksheets -
A static row height of let's say "55.55""?



Issue 3 - Maintain worksheet ("Tab") color when creating new "Fruit" sheets

So, I have my worksheet that I'm going to use the above macro on. It is currently colored "Red". When running your code, I will have a new worksheet for every different fruit listed in the "Fruit" column. Let's say I had 3 different fruits...therefore, there will be 3 newly created worksheets.

I would like the TAB COLOR of the newly created worksheets to be the same as TAB COLOR of the original worksheet, which is red. The result will be 4 worksheets (1 Original Worksheet with a "TAB" color of Red & 3 newly created worksheets with a "TAB" color of Red.


I hope I explained this correctly and obviously, please ask if this is unclear...

Thanks!

 

[Fluff]

Try

Sub CheckMove()

    Dim Dict As Object
    Dim Rng As Range
    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim Ky As Variant
    Dim FCol As Long
    Dim PCol As Long
    Dim UsdCols As Long
    Dim RwHght As Long

Application.ScreenUpdating = False
    
    Set Ws = ActiveSheet
    With Ws
        UsdCols = .Cells(1, .Columns.Count).End(xlToLeft).Column
        FCol = .Rows(1).Find("Fruit").Column
        PCol = .Rows(1).Find("Person").Column
        UsdRws = .Cells(Rows.Count, FCol).End(xlUp).Row
    End With
    
    Set Dict = CreateObject("scripting.dictionary")
    
    For Each Rng In Ws.Range(Ws.Cells(2, FCol), Ws.Cells(UsdRws, FCol))
        Dict(Rng.Text) = Ws.Cells(Rng.Row, PCol)
    Next Rng

    For Each Ky In Dict.keys
        Sheets.Add(after:=Ws).Name = Dict(Ky) & " - " & Ky
        Ws.Columns("A:AN").Copy
        Columns("A:AN").PasteSpecial Paste:=xlPasteColumnWidths
        With Ws.Range("A1")
            .AutoFilter field:=FCol, Criteria1:=Ky
            .Range(.Cells(1, 1), .Cells(UsdRws, UsdCols)).SpecialCells(xlCellTypeVisible).Copy Range("A1")
            ActiveSheet.Tab.Color = vbRed
            Cells.RowHeight = "55.55"
        End With
    Next Ky
    Ws.Activate
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub

 

[VBAProIWish]

Ok, Wow! This is workable if need be, but now I am curious....

Is it possible to copy the color of the original worksheet tab to the newly created worksheets instead of making them "red"?


I changed the worksheet TAB color and recorded the code and here's what it recorded...

    Sheets("Sheet1").Select
    With ActiveWorkbook.Sheets("Sheet1").Tab
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
    End With

What I would like to do...
Copy the "ThemeColor" and "TintandShade" of original worksheet TAB to all newly created worksheet TABS.



If this can't be done, I assume that I'll have to repeat your code and use basic colors and then change each color to "VBOrange", "VBBlue", etc.

In any case, this IS workable, and thanks much!​

Great code!​

 

[Fluff]

Try changing

ActiveSheet.Tab.Color = vbRed

to

ActiveSheet.Tab.Color = Ws.Tab.Color

This will copy the original tab color, As I am using Xl2003 I cannot use Themecolor etc

 

[VBAProIWish]

Thanks much for that Fluff!

 

[Fluff]

Glad to help