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!

 

[Fluff]

Hia
Does this do what you're after

Sub CheckMove()

    Dim Dict As Object
    Dim Rng As Range
    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim Ky As Variant

Application.ScreenUpdating = False

    UsdRws = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    Set Ws = ActiveSheet
    Set Dict = CreateObject("scripting.dictionary")
    
    For Each Rng In Sheets(1).Range("A2:A" & UsdRws)
        Dict(Rng.Text) = ""
    Next Rng

    For Each Ky In Dict.keys
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = Ky
        With Ws.Range("A1")
            .AutoFilter field:=1, Criteria1:=Ky
            .Range("a1:Q" & UsdRws).SpecialCells(xlCellTypeVisible).Copy Range("A1")
        End With
    Next Ky
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub

 

[VBAProIWish]

Thanks Fluff,

2 things...

1. The column to look for is the name Fruit
2. Is there a way to still use the unique values for the fruits, but truncate them? Some fruits are longer than the worksheet name allows.

Thanks

 

[VBAProIWish]

I'm also getting "Run-Time error 1004"
You typed an invalid name for a sheet or chart. Make sure that:

The name that you type does not exceed 31 characters...

this also needs to work on the activesheet

 

[VBAProIWish]

Ughhh,

My fault on this one....One thing I forgot to mention...

When creating each new worksheet with the fruit name, I want to keep keep the entire existing worksheet name and append a space dash space and then the fruit name at the end of it.

For example, the worksheet says "Ocean", and one fruit name is "Cherry". The newly created worksheet should be "Ocean - Cherry".

Can that be done?

Thanks so much

 

[Fluff]

Thanks Fluff,

2 things...

1. The column to look for is the name Fruit
2. Is there a way to still use the unique values for the fruits, but truncate them? Some fruits are longer than the worksheet name allows.

Thanks

1) Does the column containing the fruit vary or is it always in the same place?
2a) What fruit has more than 31 characters in its name?
2b) How do you wanted it truncated, just the first x characters?
3) Adding in the original sheet name is no problem, but this will cause more problems for point 2b

 

[VBAProIWish]

1. The "Fruit" column might not always be in the same position, so searching by name would definitely be easier.

2a. These aren't really fruits (although your emoji is VERY funny!, I literally laughed out loud!).

2b - So, after playing around with it more I got it to work, but still have the worksheet naming problem.
Here's what I think would work best...

I have another column named "Person" (also a dynamically positioned column and should be search for by name).
I will "pre-truncate" the column values in both columns ahead of time (eliminating the too-long worksheet name issue).
I would like the worksheet name to be like this... Value from the "Person" column + " - " + value from the "Fruit" column

Whew, thanks!

 

[Fluff]

Something I forgot to ask.
How many columns are there in your data or can that vary?

 

[VBAProIWish]

This can vary, I hope that's not a problem

Also, can you put the newly named worksheets directly to the right of the one it's getting the data from instead of the end?

Thanks

 

[Fluff]

Ok, how about this

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
    
    UsdCols = Cells(1, Columns.Count).End(xlToLeft).Column
    FCol = Rows(1).Find("Fruit").Column
    PCol = Rows(1).Find("Person").Column
    UsdRws = Sheets(1).Cells(Rows.Count, FCol).End(xlUp).Row
    Set Ws = ActiveSheet
    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:=Sheets(1)).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")
        End With
    Next Ky
    Ws.Activate
    Ws.Range("A1").AutoFilter
    
Application.ScreenUpdating = True
    
End Sub