I want to rearrange data to columns from table using VBA

Question

I have a long product list in excel paired with the product categories. I want to rearrange this into columns - the column name should be the product category and under every category I want to write all of the products. I'm struggling with the second part, to order the products under the categories. Do you know a quick way to do that with VBA? I attach a picture about the current set up and my code.

Thanks for the ideas!

Here is the current code:

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

do you really wish to use VBA? Why not to use Pivot Table, you will do it much more easier. — Tsiry Rakotonirina, Apr 20 '20 at 19:59
We need to do these every 2-3 months, that's why I want to automate. Btw, how can I do it in a Pivot Table? — Lacci29, Apr 20 '20 at 20:11
If you can send me this file on a link then I can show to you how to use Pivot Table. Infact, Pivot Table will do it automatically for you without your interaction at all — Tsiry Rakotonirina, Apr 20 '20 at 20:17
It's best if we stay here, can you be so kind and share the method here? — Lacci29, Apr 20 '20 at 20:24

Jugger · Answer 1 · 2020-04-21T19:43:25.660

If you're still interested in a VBA solution, give a try to the below. It should build an array with all unique categories as columns sorted ascending and with all their respective products.

This is built based on the example from your picture:

Assumes you have Products on Column A.
Categories on Column C.
The data starts from Row 2.
Pasting data starts from cell K2
You must replace Sheet1 in code with your actual sheet code name (see below how to find it or change it).

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

score 0 · Answer 2 · answered Apr 21 '20 at 02:14

Ranges, Arrays, Dictionary, Arrays and Range

This is done for the ActiveSheet since I've seen buttons on OP's image. If it's going to be used on multiple sheets, put it in a standard module, otherwise put it in the sheet's code.

Before you run the code, adjust the 4 values in the constants section.

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

I want to rearrange data to columns from table using VBA

2 Answers2

Ranges, Arrays, Dictionary, Arrays and Range