我想使用 VBA 将数据重新排列到表中的列

Question

我在 Excel 中有一个很长的产品列表，并与产品类别配对。我想将其重新排列成列 - 列名应该是产品类别，并且在每个类别下我想写所有产品。我正在努力处理第二部分，订购类别下的产品。您知道使用 VBA 的快速方法吗？我附上一张关于当前设置和我的代码的图片。

感谢您的想法！

这是当前代码：

Sub Ordering()

Dim Row As Integer, Line As Integer, Product As String, Category As String, Column As Integer

Row = 2
Line = 2

Product = Cells(Row, 1).Value
Category = Cells(Row, 3).Value
Column = Cells(Row, 4).Value

Do While Product <> ""
    Do
        If Cells(Line, Column) = "" Then
                Cells(Line, Column) = Product
                Exit Do
            Else: Line = Line + 1
            End If
    Loop While Cells(Line, Column) <> ""

    Row = Row + 1
    Line = 1
    Product = Cells(Row, 1).Value
    Category = Cells(Row, 3).Value
    Column = Cells(Row, 4).Value
 Loop

MsgBox "Grouping is successful!"
End Sub

Answer 1

范围、数组、字典、数组和范围

这是为ActiveSheet 完成的，因为我在 OP 的图像上看到了按钮。如果要在多个工作表上使用，则将其放入标准模块中，否则将其放入工作表的代码中。

在运行代码之前，调整常量部分中的 4 个值。

Option Explicit

Sub Ordering()

    Const rowHead As Long = 1       ' Headers Row
    Const colProd As String = "A"   ' Products Column
    Const colCat As String = "H"    ' Categories Column
    Const colTbl As String = "T"    ' Table Column

    Dim dict As Object              ' Dictionary Object
    Dim key                         ' Dictionary Key (For Each Control Variable)
    Dim vntProd As Variant          ' Products Array
    Dim vntCat As Variant           ' Categories Array
    Dim vntHead As Variant          ' Headers Array
    Dim vntCount As Variant         ' Count Array
    Dim vntTable  As Variant        ' Table Array
    Dim LastRow As Long             ' Last Row of Products (Categories)
    Dim i As Long                   ' Category Array and Dictionary Counter
    Dim j As Long                   ' Category and Table Array Column Counter
    Dim t As Long                   ' Table Array Row Counter
    Dim ubCat As Long               ' Category Array Upper Bound
    Dim countCat As Long            ' Current Category Count
    Dim strCat As String            ' Current Category

    ' IN WORKSHEET

    ' Calculate the row number of the last non-empty cell in Products Column.
    LastRow = Columns("A").Cells(Rows.Count, colProd).End(xlUp).Row

    ' Write Products and Categories to Arrays.
    vntProd = Range(Cells(rowHead + 1, colProd), Cells(LastRow, colProd))
    vntCat = Range(Cells(rowHead + 1, colCat), Cells(LastRow, colCat))

    ' IN DICTIONARY AND ARRAYS

    ' Retrieve and count the unique categories using the Dictionary object.
    ubCat = UBound(vntCat)
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To ubCat
        dict(vntCat(i, 1)) = dict(vntCat(i, 1)) + 1
    Next i
    ' Resize Headers and Count Array to number of elements in Dictionary.
    ReDim vntHead(dict.Count - 1)
    ReDim vntCount(dict.Count - 1)
    ' Populate Headers and Count Array with data from Dictionary,
    i = 0
    For Each key In dict.Keys
        vntHead(i) = key
        vntCount(i) = dict(key)
        i = i + 1
    Next key

    ' IN ARRAYS

    ' Resize Table Array, for rows to max number of occurrences
    ' of a category in Count Array + 1 for headers,
    ' and for columns to number of headers.
    ReDim vntTable(1 To Application.WorksheetFunction.Max(vntCount) + 1, _
      1 To UBound(vntHead) + 1)

    ' Write headers to Table Array.
    For i = 0 To UBound(vntHead): vntTable(1, i + 1) = vntHead(i): Next
    ' Loop through elements in first row (headers) of Table Array.
    For j = 1 To UBound(vntTable, 2)
        ' Reset Table Row Counter.
        t = 1
        ' Write current value (header) in Table Array to Current Category.
        strCat = vntTable(1, j)
        ' Write current value to Current Category Count.
        countCat = vntCount(j - 1)
        ' Write data to Table Array.
        For i = 1 To ubCat
            If vntCat(i, 1) = strCat Then
                t = t + 1
                vntTable(t, j) = vntProd(i, 1)
            End If
            If t = countCat + 1 Then Exit For
        Next
    Next

    ' IN WORKSHEET

    With Cells(rowHead, colTbl)
        ' Clear contents of whole columns of Table Range.
        '.Offset(1 - rowHead).Resize(.Parent.Rows.Count, UBound(vntTable, 2)) _
          .ClearContents
        ' Fill headers with color yellow.
        '.Resize(, UBound(vntTable, 2)).Interior.ColorIndex = 6

        ' Write values of Table Array to Table Range.
        .Resize(UBound(vntTable), UBound(vntTable, 2)) = vntTable
    End With

    MsgBox "Grouping was successful!"

End Sub

Answer 2

如果您仍然对 VBA 解决方案感兴趣，请尝试以下方法。它应该构建一个数组，其中包含所有唯一类别作为按升序排序的列以及它们各自的产品。

这是根据您图片中的示例构建的：

• 假设您在 A 列上有Products。
• C 列上的Categories。
• 数据从第 2 行开始。
• 从单元格K2开始粘贴数据
• 您必须将代码中的Sheet1 替换为您的实际工作表代码名称（请参阅下文如何找到或更改它）。

Option Explicit

Public Sub StackQuestion()
    Dim Dict            As Object
    Dim Data            As Variant
    Dim Categories()    As Variant
    Dim LastRow         As Long
    Dim ArrSize         As Long
    Dim i As Long, j    As Long

    Set Dict = CreateObject("Scripting.Dictionary")

    ' Create an array with categories (replace Sheet1 with your sheet code name)
    With Sheet1
        LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        ' Loads the data from Column C to an array starting from 2nd row
        ' Assumes this is your Category column
        Categories = Application.WorksheetFunction.Transpose(.Range("C2:C" & LastRow).Value2)

        ' Loads the data from Column A to Column C starting from 2nd row
        Data = .Range("A2:C" & LastRow).Value2
    End With

    ' Remove duplicates
    For i = LBound(Categories) To UBound(Categories)
        If Categories(i) <> vbNullString Then Dict(Categories(i)) = Empty
    Next i

    Categories = Dict.Keys
    Set Dict = Nothing

    ' Sort categories ascending
    Call QuickSort(Categories, LBound(Categories), UBound(Categories))

    ' Convert to multi-dimensional using the current data as column headers
    Categories = Application.WorksheetFunction.Transpose(Categories)

    ' Check items for each product and add to array
    For i = LBound(Categories) To UBound(Categories)

        ArrSize = LBound(Categories, 2)
        For j = LBound(Data) To UBound(Data)

            If Categories(i, 1) = Data(j, 3) Then
                ArrSize = ArrSize + 1

                If UBound(Categories, 2) <= ArrSize Then
                    ReDim Preserve Categories(LBound(Categories) To UBound(Categories), LBound(Categories, 2) To ArrSize)
                End If

                Categories(i, ArrSize) = Data(j, 1)
            End If
        Next j
    Next i

    With Sheet1.Range("K2")
        ' Clear range before
        .CurrentRegion.ClearContents

        ' Paste the array (replace Sheet1 with your sheet code name)
        .Resize(UBound(Categories, 2), UBound(Categories)).Value2 = Application.WorksheetFunction.Transpose(Categories)
    End With
End Sub

' https://stackoverflow.com/questions/152319/vba-array-sort-function
' Been using this one for a while
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long

    tmpLow = inLow
    tmpHi = inHi

    pivot = vArray((inLow + inHi) \ 2)

    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend

        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend

        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend

    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub