How to split categorical data in Excel (using VBA)

Question

Some sample data:

Fruit Type | Price | Weight
Apple | $1 | 0.5
Pear | $2 | 0.3
Apple | $1.2 | 0.4
Banana | $1.1 | 0.2

I need a macro that does this:

Sort the data by Fruit Type (a categorical variable). Then, for all the Apples, copy and paste them somewhere. For all the Bananas, copy and paste them somewhere. For all the Pears, copy and paste them somewhere.

However, the solution needs to fit any Fruit Type (I won't know in advance what my categories are).

How can I solve this? I am open to using VBA. I cannot figure out how to split the data by categories.

Answer 1

you may try this (explanations in comments):

Option Explicit

Sub main()
    Dim cell As Range, dict As Object, key As Variant
    Dim targetSht As Worksheet

    Set dict = CreateObject("Scripting.Dictionary")

    With Worksheets("fruits") 'reference data sheet (change "fruits" to your actual data sheet name)
        With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) 'reference its column A cells from row 1 (header) down to last not empty one
            For Each cell In .Offset(1).Resize(.Rows.Count - 1) 'loop through referenced cells skipping first row (header)
                dict.Item(cell.value) = cell.value 'fill dictionary keys with unique fruit names
            Next
            For Each key In dict.Keys 'loop through dictionary keys
                Set targetSht = GetOrCreateSheet(key) 'get or create the sheet corresponding to current key (i.e.: fruit)
                .AutoFilter Field:=1, Criteria1:=key ' filter referenced cells on 1st column with current fruit
                .Offset(1).Resize(.Rows.Count - 1, 3).SpecialCells(xlCellTypeVisible).Copy Destination:=targetSht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'copy filtered cells skipping headers and paste them to target sheet starting from its column A first not empty row
            Next
        End With
        .AutoFilterMode = False
    End With
End Sub

Function GetOrCreateSheet(shtName As Variant) As Worksheet
    On Error Resume Next
    Set GetOrCreateSheet = Worksheets(shtName)
    If GetOrCreateSheet Is Nothing Then
        Worksheets.Add.name = shtName
        Set GetOrCreateSheet = ActiveSheet
    End If
End Function

Answer 2

Here is a start for 10. I will add more commentary after meeting. Note: Does require .Net framework.

Option Explicit

Public Sub FruitItems()

    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("fruitData")
    Dim lastRow As Long

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Dim fruitDataArray()
    fruitDataArray = ws.Range("A1:C" & lastRow)

    Dim fruitSortedList As Object
    Set fruitSortedList = CreateObject("System.Collections.Sortedlist")

    Dim currentFruit As Long

    On Error Resume Next

    For currentFruit = LBound(fruitDataArray, 1) + 1 To UBound(fruitDataArray, 1)

        fruitSortedList.Add fruitDataArray(currentFruit, 1), fruitDataArray(currentFruit, 1)

    Next currentFruit

    On Error GoTo 0

    Dim i As Long

    For i = 0 To fruitSortedList.Count - 1
        'Debug.Print fruitSortedList.GetKey(i) & vbTab & fruitSortedList.GetByIndex(i)

    For currentFruit = LBound(fruitDataArray, 1) + 1 To UBound(fruitDataArray, 1)

        If fruitDataArray(currentFruit, 1) = fruitSortedList.GetKey(i) Then 'sorted order

            Dim newSheet As Worksheet
            Dim fruitName As String
            fruitName = fruitDataArray(currentFruit, 1)

            If SheetExists(fruitName) Then

                 Set newSheet = wb.Worksheets(fruitName)

            Else

                Set newSheet = wb.Worksheets.Add(After:=wb.Worksheets(Worksheets.Count))
                newSheet.Name = fruitName

            End If

            Dim counter As Long

            counter = GetLast(newSheet, True) + 1

            With newSheet

                .Cells(counter, 1) = fruitDataArray(currentFruit, 1)
                .Cells(counter, 2) = fruitDataArray(currentFruit, 2)
                .Cells(counter, 3) = fruitDataArray(currentFruit, 3)
                counter = counter + 1
            End With

            Set newSheet = Nothing

        End If

    Next currentFruit

    Next i

End Sub

'@TimWilliams
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    SheetExists = Not sht Is Nothing
End Function
'@Raystafarian
Private Function GetLast(ByVal targetSheet As Worksheet, ByVal isRow As Boolean) As Long
    If isRow Then
        GetLast = targetSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Else
        GetLast = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    End If
End Function

References:

1. https://codereview.stackexchange.com/questions/187246/reorder-columns-in-array
2. https://msdn.microsoft.com/en-us/library/system.collections.sortedlist(v=vs.110).aspx
3. http://www.robvanderwoude.com/vbstech_data_sortedlist.php
4. Adding sheets to end of workbook in Excel (normal method not working?)
5. Test or check if sheet exists