De-Stacking columns in Excel using VBA

Question

I have a dataset in three columns composed of a repeating set of UUIDs in the first column, string responses for each UUID in the second, and a code for each response in the third. I need to break this out into multiple sets of columns, one for each repeating set of UUIDs. See the below illustration:

I Have:

UUID    RESPONSE    Resp. Code 
id1     String1     Code1
id2     String2     Code7
id3     String3     Code3
id1     String4     Code3
id2     String5     Code5
id3     String6     Code1

I need:

UUID    RESPONSE    Resp. Code  RESPONSE    Resp. Code 
id1     String1     Code1       String4     Code3
id2     String2     Code7       String5     Code5
id3     String3     Code3       String6     Code1

Note that while there are 3 UUIDs illustrated here, I'm actually dealing with 1377.

I've attempted to write a macro for this operation (pasted below), but I am a complete noob to VBA and Excel macros, so it is hacky and does not do even close what I want it to.

    Sub DestackColumns()
    Dim rng As Range
    Dim iCell As Integer
    Dim lastCol As Integer
    Dim iCol As Integer

    Set rng = ActiveCell.CurrentRegion
    lastCol = rng.Rows(1).Columns.Count

    For iCell = 3 To rng.Rows.Count Step 3
        Range(Cells(1, iCell), Cells(2, iCell)).Cut
        ActiveSheet.Paste Destination:=Cells(lastCol, 1)
    Next iCell
    End Sub

All help appreciated!

Answer 1

One take on a VBA code that will achieve this is:

Sub DestackColumns()
    Dim Source As Worksheet
    Dim Output As Worksheet
    Dim DistArr As Variant
    Dim i As Integer
    Dim j As Integer
    Dim OutRow As Integer

    Set Source = ActiveSheet
    Sheets.Add After:=ActiveWorkbook.Sheets(ActiveSheet.Index)
    Set Output = ActiveSheet

    Output.Name = "Destack"
    Output.Range("A1").Value = "UUID"

    'Find distinct UUID's
    DistArr = ReturnDistinct(Source.Range("A2:" & Source.Cells(Rows.Count, 1).End(xlUp).Address))

    'Loop through distinct UUID's
    For i = LBound(DistArr) To UBound(DistArr)
        OutRow = Output.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Output.Cells(OutRow, 1).Value = DistArr(i)

        'Loop source sheet
        For j = 2 To Source.Cells(Rows.Count, 1).End(xlUp).Row
            'IF UUID match
            If Source.Cells(j, 1).Value = DistArr(i) Then
                'Insert values
                Output.Cells(OutRow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Source.Cells(j, 2).Value
                Output.Cells(OutRow, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Source.Cells(j, 3).Value
            End If
        Next j
    Next i

End Sub


Private Function ReturnDistinct(InpRng) As Variant
    Dim Cell As Range
    Dim i As Integer
    Dim DistCol As New Collection
    Dim DistArr()

    If TypeName(InpRng) <> "Range" Then Exit Function

    'Add all distinct values to collection
    For Each Cell In InpRng
        On Error Resume Next
        DistCol.Add Cell.Value, CStr(Cell.Value)
        On Error GoTo 0
    Next Cell

    'Write collection to array
    ReDim DistArr(1 To DistCol.Count)
    For i = 1 To DistCol.Count Step 1
        DistArr(i) = DistCol.Item(i)
    Next i

    ReturnDistinct = DistArr
End Function

This code will place the new data structure on a new sheet (i.e. not overwrite your original data) and with this code you do not need to worry about if the data is sorted properly.

Answer 2

Here is a somewhat different approach. I have set up a user defined class called cUUID. The class has the properties of the UUID, Response, ResponseCode and a Collection consisting of the paired Response and ResponseCode.

We create a Collection of this class object, where each member of the collection is a specific UUID (since that's how you want to group them).

The code iterates through your data source, creating these objects "on the fly". We then create an array containing all the results, and write this array to a different worksheet.

It should be obvious in the code how to change those worksheet names, and, if necessary, the locations of the source data and results.

After you Insert the Class Module, you must select it, F4 and rename it cUUID

Class Module

Option Explicit
Private pUUID As String
Private pResponse As String
Private pRespCode As String
Private pCol As Collection

Public Property Get UUID() As String
    UUID = pUUID
End Property
Public Property Let UUID(Value As String)
    pUUID = Value
End Property

Public Property Get Response() As String
    Response = pResponse
End Property
Public Property Let Response(Value As String)
    pResponse = Value
End Property

Public Property Get RespCode() As String
    RespCode = pRespCode
End Property
Public Property Let RespCode(Value As String)
    pRespCode = Value
End Property

Public Property Get Col() As Collection
    Set Col = pCol
End Property

Public Sub Add(Resp1 As String, RC As String)
    Dim V(1 To 2) As Variant
    V(1) = Resp1
    V(2) = RC
    Col.Add V
End Sub

Private Sub Class_Initialize()
    Set pCol = New Collection
End Sub


Private Sub Class_Terminate()
    Set pCol = Nothing
End Sub

---

Regular Module

Option Explicit
Sub ConsolidateUUIDs()
    Dim cU As cUUID, colU As Collection
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim RespPairs As Long
    Dim I As Long, J As Long

Set wsSrc = Worksheets("Sheet1")
Set wsRes = Worksheets("Sheet2")
Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, "C").End(xlUp))
End With

'Collect the data
Set colU = New Collection
RespPairs = 1
On Error Resume Next
For I = 2 To UBound(vSrc)
    Set cU = New cUUID
    With cU
        .UUID = vSrc(I, 1)
        .Response = vSrc(I, 2)
        .RespCode = vSrc(I, 3)
        .Add .Response, .RespCode
        colU.Add cU, CStr(.UUID)
        Select Case Err.Number
            Case 457
                Err.Clear
                colU(CStr(.UUID)).Add .Response, .RespCode
                J = colU(CStr(.UUID)).Col.Count
                RespPairs = IIf(J > RespPairs, J, RespPairs)
            Case Is <> 0
                Debug.Print Err.Number, Err.Description
                Stop
        End Select
    End With
Next I
On Error GoTo 0

'Sort Collection by UUID
CollectionBubbleSort colU, "UUID"

'Create Results Array
ReDim vRes(0 To colU.Count, 0 To RespPairs * 2)

'header row
vRes(0, 0) = "UUID"
For J = 0 To RespPairs - 1
    vRes(0, J * 2 + 1) = "RESPONSE"
    vRes(0, J * 2 + 2) = "Resp.Code"
Next J

'Data rows
For I = 1 To colU.Count
    With colU(I)
        vRes(I, 0) = .UUID
        For J = 1 To colU(I).Col.Count
            vRes(I, (J - 1) * 2 + 1) = colU(I).Col(J)(1)
            vRes(I, (J - 1) * 2 + 2) = colU(I).Col(J)(2)
        Next J
    End With
Next I

'Write the results array
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

'-------------------------------------------------------
'Could use faster sort routine if necessary
Sub CollectionBubbleSort(TempCol As Collection, Optional Prop As String = "")
'Must manually insert element of collection to sort on in this version
    Dim I As Long
    Dim NoExchanges As Boolean

    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True

        ' Loop through each element in the array.
        For I = 1 To TempCol.Count - 1

If Prop = "" Then

            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If TempCol(I) > TempCol(I + 1) Then
                NoExchanges = False
                TempCol.Add TempCol(I), after:=I + 1
                TempCol.Remove I
            End If
Else
        If CallByName(TempCol(I), Prop, VbGet) > CallByName(TempCol(I + 1), Prop, VbGet) Then
                NoExchanges = False
                TempCol.Add TempCol(I), after:=I + 1
                TempCol.Remove I
            End If
End If
        Next I
    Loop While Not (NoExchanges)
End Sub

---

The UUID's will be sorted alphabetically. The code should work with varying numbers of UUID's, and varying numbers of responses to each of the UUID's.

Answer 3

Your sample code indicates that you wish to remove the original values in favor of the new matrix. To that end, I would suggest running this on a copy of the data first.

Sub stack_horizontally()
    Dim rw As Long, mrw As Long

    With ActiveSheet   '<-set this worksheet name properly!
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
            mrw = Application.Match(.Cells(rw, 1), .Columns(1), 0)
            If mrw < rw Then
                .Cells(mrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 2).Value
                .Cells(mrw, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 3).Value
                .Rows(rw).Delete
            End If
        Next rw
    End With
End Sub

I haven't populated the headers into the new columns but that should be a minor manual operation.