如何在Excel中拆分分类数据（使用VBA）

一些样本数据：

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

我需要一个宏来执行以下操作：

按水果类型（分类变量）对数据进行排序。然后，对于所有的苹果，复制并粘贴到某个地方。对于所有的香蕉，复制并粘贴到某个地方。对于所有的梨，复制并粘贴到某个地方

但是，解决方案需要适合任何水果类型（我不知道我的类别是什么）

---

我怎样才能解决这个问题？我愿意使用VBA。我不知道如何按类别划分数据。

这里是10的开始。会后我会补充更多的评论。 注意：不需要.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

参考资料：

您可以尝试以下方法（注释中的解释）：

---

您可以通过VBA或手动使用

Autofilter

。到目前为止你做了什么？堆栈溢出时，您将无法获得满足您需要的自定义编写代码。确定将签出

autofilter

。目前我的困难是我不知道有什么方法或函数可以被分类变量拆分。@JamesSoh，有什么反馈吗？

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