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!
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.
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.
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.
