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]

Fluff,

WWwwoowwWW!
​

That is almost EXACTLY what I wanted! Sooo, close

Your macro creates the new worksheets directly to the LEFT of the active worksheet instead of directly to the right. Can you change this to be directly to the right of the active worksheet?

I have one more new request and then this is completed.

When creating new worksheets, I noticed that my pre-set row heights are gone. I assume it's because when populating the new worksheets, the rows are set to "auto-fit row height" or it's set as "values only". Can you make it so that the row height stays the same for each row just it was on the original worksheet?


This is it! If I don't answer right away, many many thanks!

 

[Fluff]

Sounds like you have more than 1 sheet initially

Option Explicit

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

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
        With Ws.Range("A1")
            .AutoFilter field:=FCol, Criteria1:=Ky
            .Range(.Cells(1, 1), .Cells(UsdRws, UsdCols)).SpecialCells(xlCellTypeVisible).Copy Range("A1")
            Cells.RowHeight = .Cells.RowHeight
        End With
    Next Ky
    Ws.Activate
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub

 

[VBAProIWish]

I'll check this out on Monday.

Thanks much Fluff!

Sounds like you have more than 1 sheet initially

Option Explicit

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

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
        With Ws.Range("A1")
            .AutoFilter field:=FCol, Criteria1:=Ky
            .Range(.Cells(1, 1), .Cells(UsdRws, UsdCols)).SpecialCells(xlCellTypeVisible).Copy Range("A1")
            Cells.RowHeight = .Cells.RowHeight
        End With
    Next Ky
    Ws.Activate
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub

 

[Fluff]

Glad to help & have a good weekend

 

[VBAProIWish]

Hello,

This is soooo close and thanks again for your patience. So we are 99% there now.

Two more things...

1. It's still not doing is keeping row heights and column widths the same when creating the new worksheets.
2. The worksheet is a certain color. Is there any way to keep the same color when creating the new worksheets?

I'm hoping that it's something fairly easy to do?

Thanks much!

 

[Fluff]

Do you have varying row heights & column widths?

 

[VBAProIWish]

Basically, whatever is in the original worksheet, I would want exactly the same for the newly created worksheets. I already know though, that Auto-Fit column width and Row height won't work because it makes the columns too wide and the rows too high.

Thanks

 

[Fluff]

If you have varying row heights & column widths the only way I know to do it would be to run multiple loops on over the original data for each new sheet.
However if the row heights & columns widths are consistent then that is simple.

 

[VBAProIWish]

Ok, I think I can figure that part out.

Can you help me with keeping the color of the newly created worksheets the same?

 

[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

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
        With Ws.Range("A1")
            .AutoFilter field:=FCol, Criteria1:=Ky
            .Range(.Cells(1, 1), .Cells(UsdRws, UsdCols)).SpecialCells(xlCellTypeVisible).Copy Range("A1")
            [COLOR=#ff0000]Cells.Interior.Color = .Range("A1").Interior.Color[/COLOR]
            Cells.RowHeight = .Cells.RowHeight
        End With
    Next Ky
    Ws.Activate
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub

The relevant line is in red & assumes that A1 is coloured