Reorganizing an Excel Sheet, one column into many columns [duplicate] - excel

Question

This question already has answers here:
Aggregate, Collate and Transpose rows into columns
(3 answers)
Closed 6 years ago.
I'm pretty new to stack overflow but I've been on here as a lurker before.
So I'm having trouble reorganizing this excel output. The original output is below. I've modified the output to preserve the confidentiality of the dataset and also in the interest of time as the dataset has over 10k cells, but the ideas should be clear.
Before
As you can see, there's a lot of duplicates and useless stuff and in general annoying bits. Basically I need to reorganize the data into column headers and repopulate the spreadsheet so that the data stays with the proper code number. The current column headers of supercatagory and subcategory are worthless. I've attached what I think would be the ideal here. After
I've tried using pivot tables and that kind of serves as a half measure but that would still require me to go through the output and copy and paste by hand for over 2 hours. I've also tried using transpose in excel and while that is good for the first part of the problem, making new column headers, but it doesn't solve the problem of repopulating the spreadsheet and keeping everything straight.
Thank you so much.

Answer 1

Without knowing more, the below code works for me in testing with the data provided in your images. The big question of course is where the column headers in the After data came from. It appeared to come from column B of the Before data. I assumed these would be duplicated for each unique value from column A. As such, in the below code, only the first set of values is used to set the headers of the newly created sheet.
Option Explicit
Sub TransposeWithUniques()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim Uniques As Collection
Dim Unique As Variant
Dim UniqueData() As Variant
Dim FormulaColumn As Range
Dim CriteriaColumn As Range
Dim DataRange As Range
Dim FoundRange As Range
Dim ValueIndex As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim NewRow As Long
Dim ErrorFound As Boolean
Set SourceSheet = ActiveSheet '!!! This will need to be the currently active sheet housing your data
' If sheet is protected, exit
If SourceSheet.ProtectContents Then
MsgBox "Please unprotect the worksheet first.", vbExclamation, "Transpose with Uniques"
Exit Sub
End If
' Get last row/column
LastRow = SourceSheet.Cells(SourceSheet.Rows.Count, 1).End(xlUp).Row
LastColumn = SourceSheet.Cells(1, SourceSheet.Columns.Count).End(xlToLeft).Column
Set DataRange = SourceSheet.Range("A1", SourceSheet.Cells(LastRow, LastColumn))
NewRow = 1
' Get unique UniqueData from column A
UniqueData = SourceSheet.Range("A2:A" & LastRow).Value2
Set Uniques = New Collection
For ValueIndex = LBound(UniqueData, 1) To UBound(UniqueData, 1)
If InCollection(Uniques, CStr(UniqueData(ValueIndex, 1))) = False Then
Uniques.Add UniqueData(ValueIndex, 1), CStr(UniqueData(ValueIndex, 1))
End If
Next ValueIndex
' Set application properties for better code running experience
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
' Add helper columns
On Error GoTo TransposeWithUniques_Error
SourceSheet.Cells(1, LastColumn).Offset(0, 1).Resize(LastRow, 2).Insert
Set CriteriaColumn = SourceSheet.Cells(1, LastColumn).Offset(0, 1).Resize(LastRow, 1)
Set FormulaColumn = SourceSheet.Cells(1, LastColumn).Offset(0, 2).Resize(LastRow, 1)
FormulaColumn(1, 1).Value = "FORMULA"
CriteriaColumn(1, 1).Value = "CRITERIA"
FormulaColumn(2, 1).Resize(LastRow - 1, 1).Formula = "=ROW(A1)"
FormulaColumn(2, 1).Resize(LastRow - 1, 1).Value = FormulaColumn(2, 1).Resize(LastRow - 1, 1).Value
' Loop through all uniques, get data and move it
For Each Unique In Uniques
CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Formula = "=1/(A2=" & Chr(34) & Unique & Chr(34) & ")"
CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Value = CriteriaColumn(2, 1).Resize(LastRow - 1, 1).Value
DataRange.Resize(, DataRange.Columns.Count + 2).Sort Key1:=CriteriaColumn(1, 1), Order1:=xlAscending, Key2:=SourceSheet.Range("B1"), Order2:=xlAscending, Header:=xlYes
On Error Resume Next
Set FoundRange = CriteriaColumn.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not FoundRange Is Nothing Then
If TargetSheet Is Nothing Then
Set TargetSheet = ActiveWorkbook.Worksheets.Add(After:=SourceSheet)
TargetSheet.Range("A1").Value = SourceSheet.Range("A1").Value
TargetSheet.Range("B1").Resize(1, FoundRange.Cells.Count).Value = Application.Transpose(Intersect(SourceSheet.Range("B:B"), FoundRange.EntireRow).Value)
End If
NewRow = NewRow + 1
TargetSheet.Cells(NewRow, 1).Value = Unique
TargetSheet.Cells(NewRow, 2).Resize(1, FoundRange.Cells.Count).Value = Application.Transpose(Intersect(SourceSheet.Range("C:C"), FoundRange.EntireRow).Value)
Set FoundRange = Nothing
End If
Next Unique
' Reset data to original state
DataRange.Resize(, DataRange.Columns.Count + 2).Sort Key1:=FormulaColumn(1, 1), Order1:=xlAscending, Header:=xlYes
FormulaColumn.Delete xlToLeft
CriteriaColumn.Delete xlToLeft
TransposeWithUniques_Exit:
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
If Not ErrorFound Then
MsgBox "Process completed successfully.", vbInformation, "Transpose with Uniques"
End If
Exit Sub
TransposeWithUniques_Error:
ErrorFound = True
MsgBox "Something went wrong.", vbExclamation, "Transpose with Uniques"
GoTo TransposeWithUniques_Exit
End Sub
Public Function InCollection(CheckCollection As Collection, CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Syntax: InCollection(CheckCollection,CheckKey)
'
' Parameters: CheckCollection. Collection. Required. The collection to search in.
' CheckKey. String. Required. The string key to search in collection for.
'
On Error Resume Next
InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
On Error GoTo 0
End Function
To use the above code, in your file you want to run this on, press ALT+F11 to open the Visual Basic Editor (VBE). Press CTRL+R to show the Project Explorer (PE), generally this shows by default. Find your project in the PE and right-click it, select Insert, Module. Double click the newly inserted module (should be named Module1). Copy/paste the above code into this module. Click anywhere inside the top routine (for example, click on the text near the top "TransposeWithUniques" so your cursor is on that line, or just below it). Press F5 to run the routine.
CAUTION: Make sure you save a backup copy of your file prior to running this. It resets the data to its original state, but this is always good practice. Check the newly created sheet to ensure it's what you're looking for. If this isn't what you're looking for, please be as specific as possible in explaining the input versus output.
Regards,
Zack Barresse