Я хочу переставить данные в столбцы из таблицы с помощью 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, поскольку я видел кнопки на изображении ОП. Если он будет использоваться на нескольких листах, поместите его в стандартный модуль, в противном случае поместите его в код листа.

Перед запуском кода настройте 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, попробуйте следующее. Он должен создать массив со всеми уникальными категориями в виде столбцов, отсортированных по возрастанию, и со всеми соответствующими продуктами.

Это построено на основе примера из вашей картинки:

• Предполагается, что у вас есть Products в столбец A .
• Categories в столбец C.
• Данные начинаются с Строка 2 .
• Вставка данных начинается с ячейки K2
• Вы должны заменить Sheet1 в коде своим реальным кодовым именем листа (см. Ниже, как найти или изменить его). ).