De-stacking columns in Excel with VBA
I have a 3-column dataset consisting 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 split this into multiple sets of columns, one for each repeating set of UUIDs. See the illustration below:
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 although 3 UUIDs are shown here, I am actually dealing with 1377.
I tried to write a macro for this operation (insert below), but I'm a complete noob for VBA and Excel macros, so it's a hack and doesn't even close what I want.
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 is appreciated!
source to share
Here's a slightly different approach. I have created a custom cUUID class. The class has UUID, Response, ResponseCode, and Collection properties consisting of a paired Response and ResponseCode.
We create a collection of this class object where each member of the collection is a specific UUID (since you want to group them).
The code iterates through the data source, creating these objects on the fly. Then we create an array containing all the results and write that array to another worksheet.
It should be obvious in the code how to change the names of these sheets and, if necessary, the location of the source data and results.
After you have entered a 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 will be sorted alphabetically. The code should work with different UUID numbers and different number of responses for each of the UUIDs.
source to share
Take the VBA code that will achieve this:
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 puts the new data structure on a new sheet (i.e. does not overwrite the original data), and with this code, you don't have to worry about whether the data is sorted correctly.
source to share
Your code example indicates that you want to remove the original values in favor of a new matrix. To do this, I 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 didn't fill in the headers in the new columns, but it should be a minor manual control.
source to share