Question

一些示例数据：

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

我需要一个执行此操作的宏：

按水果类型（分类变量）对数据进行排序。然后，对于所有苹果，将它们复制并粘贴到某处。对于所有香蕉，将它们复制并粘贴到某处。对于所有Pears，将它们复制并粘贴到某处。

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

我该如何解决这个问题？我愿意使用VBA。我无法弄清楚如何按类别拆分数据。

Answer 1

你可以试试这个（评论中的解释）：

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

这是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

参考文献：

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

2 个答案: