Rearranging cells Excel VBA - excel

Question

I'm trying to rearrange a large data set and am thinking VBA is the best, most effective method to do this.
I have a data set similar to this structure:
and with this data, I'm trying to get this output:
Has anyone written anything to do this sort of thing? I'd be most grateful for any suggestions or advise on where to go with this.
Many thanks,

Answer 1

Transpose Data (Rearrange)
Adjust the values in the constants section to fit your needs.
Links
Workbook Download (Dropbox)
Images
Source (Sheet1)
Target 1 (Sheet2)
Target 2 (Sheet3)
ID is not gonna happen because, like Ted in the previous version, it is nowhere to be found.
Version 1
Sub TransposeData1()
' Source
Const cSource As String = "Sheet1" ' Worksheet Name
Const cFR As Long = 2 ' First Row Number
Const cFRC As Variant = "A" ' First-Row Column Letter/Number
Const cRep As String = "B" ' Repeat Columns Range Address
Const cUni As String = "C:G" ' Unique Columns Range Address
' Target
Const cTarget As String = "Sheet2" ' Worksheet Name
Const cHeaders As String = "IDDiff,Supervisor,Primary,Secondary"
Const cSupervisor As String = "Ted" ' Supervisor
Const cFCell As String = "A1" ' First Cell Range Address
' Source
Dim rng As Range ' First-Row Column Last Used Cell Range
Dim vntR As Variant ' Repeat Array
Dim vntU As Variant ' Unique Array
Dim NoR As Long ' Number of Records
' Target
Dim vntH As Variant ' Header Array
Dim vntT As Variant ' Target Array
Dim CUR As Long ' Current Column
Dim i As Long ' Target Array Row Counter
Dim j As Long ' Target/Repeat Array Column Counter
Dim k As Long ' Repeat/Unique Array Row Counter
Dim m As Long ' Unique Array Column Counter
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource).Columns(cFRC)
' In First-Row Column
With .Columns(cFRC)
' Calculate First-Row Column Last Used Cell Range.
Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
' Check if no data in First-Row Column.
If rng Is Nothing Then
MsgBox "No data in column '" _
& Split(.Cells(1).Address, "$")(1) & "'."
GoTo ProcedureExit
End If
' Calculate Number of Records needed to calculate Repeat Range
' and Unique Range.
NoR = rng.Row - cFR + 1
End With
' In Repeat Columns
With .Columns(cRep)
' Copy calculated Repeat Range to Repeat Array.
vntR = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
End With
' In Unique Columns
With .Columns(cUni)
' Copy calculated Unique Range to Unique Array.
vntU = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
End With
End With
' In Arrays
' Resize Target Array:
' Rows
' 1 - for Headers.
' NoR * Ubound(vntU, 2) - for data.
' Columns
' 1 - for IDs.
' 1 - for Supervisor.
' UBound(vntR, 2) - for Repeat Array Columns.
' 1 - for unique values.
ReDim vntT(1 To 1 + NoR * UBound(vntU, 2), _
1 To 1 + 1 + UBound(vntR, 2) + 1)
' Headers to Header Array
vntH = Split(cHeaders, ",")
' Header Array to Target Array
For j = 1 To UBound(vntT, 2)
vntT(1, j) = Trim(vntH(j - 1))
Next
' IDs to Target Array
CUR = CUR + 1 ' Calculate Current Column in Target Array.
For i = 2 To UBound(vntT)
vntT(i, CUR) = i - 1
Next
' Supervisor to Target Array
CUR = CUR + 1 ' Calculate Current Column in Target Array.
For i = 2 To UBound(vntT)
vntT(i, CUR) = cSupervisor
Next
' Repeat Array to Target Array
CUR = CUR + 1 ' Calculate Current Column in Target Array.
i = 1 ' First row of Target Array contains Headers.
' Task: Write values of current rows (k) in columns (j) in Repeat Array
' to current rows (i) in columns (j + CUR - 1) of Target Array as many
' times as there are columns (m) in Unique Array.
For k = 1 To UBound(vntR) ' Rows of Repeat Array
For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
i = i + 1 ' Count current row of Target Array.
For j = 1 To UBound(vntR, 2) ' Columns of Repeat Array
' Write value of current record in Repeat Array
' to current record of Target Array.
vntT(i, j + CUR - 1) = vntR(k, j)
Next
Next
Next
' Unique Array to Target Array
CUR = CUR + UBound(vntR, 2) ' Calculate Current Column in Target Array.
i = 1 ' First row of Target Array contains Headers.
' Task: Write values of current row (k) and current column (m) of Unique
' Array each to the next row (i) in current column (CUR) of Target Array.
For k = 1 To UBound(vntU) ' Rows of Unique Array
For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
i = i + 1 ' Count current row of Target Array.
' Write value of current record in Unique Array
' to current record of Target Array.
vntT(i, CUR) = vntU(k, m)
Next
Next
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget).Range(cFCell)
' Clear contents of Target Range and the range below it.
.Resize(.Parent.Rows.Count - .Parent.Range(cFCell).Row + 1, _
UBound(vntT, 2)).ClearContents
' Copy Target Array to Target Range.
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Version 2
Sub TransposeData2()
' Source
Const cSource As String = "Sheet1" ' Worksheet Name
Const cFR As Long = 2 ' First Row Number
Const cFRC As Variant = "A" ' First-Row Column Letter/Number
Const cRep As String = "A:B" ' Repeat Columns Range Address
Const cUni As String = "C:G" ' Unique Columns Range Address
Const cUH As Long = 1 ' Unique Header Row Number
' Target
Const cTarget As String = "Sheet3" ' Worksheet Name
Const cHeaders As String = "ID,Primary,Secondary,Relationship"
Const cFCell As String = "A1" ' First Cell Range Address
' Source
Dim rng As Range ' First-Row Column Last Used Cell Range
Dim vntR As Variant ' Repeat Array
Dim vntU As Variant ' Unique Array
Dim NoR As Long ' Number of Records
' Target
Dim vntH As Variant ' Header Array
Dim vntT As Variant ' Target Array
Dim vntUH As Variant ' Unique Header Array
Dim CUR As Long ' Current Column
Dim i As Long ' Target Array Row Counter
Dim j As Long ' Target/Repeat Array Column Counter
Dim k As Long ' Repeat/Unique Array Row Counter
Dim m As Long ' Unique/Unique Header Array Column Counter
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource).Columns(cFRC)
' In First-Row Column
With .Columns(cFRC)
' Calculate First-Row Column Last Used Cell Range.
Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
' Check if no data in First-Row Column.
If rng Is Nothing Then
MsgBox "No data in column '" _
& Split(.Cells(1).Address, "$")(1) & "'."
GoTo ProcedureExit
End If
' Calculate Number of Records needed to calculate Repeat Range
' and Unique Range.
NoR = rng.Row - cFR + 1
End With
' In Repeat Columns
With .Columns(cRep)
' Copy calculated Repeat Range to Repeat Array.
vntR = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
End With
' In Unique Columns
With .Columns(cUni)
' Copy calculated Unique Range to Unique Array.
vntU = .Cells(1).Offset(cFR - 1).Resize(NoR, .Columns.Count)
' Copy calculated Unique Header Range to Unique Header Array.
vntUH = .Cells(1).Offset(cUH - 1).Resize(, .Columns.Count)
End With
End With
' In Arrays
' Resize Target Array:
' Rows
' 1 - for Headers.
' NoR * Ubound(vntU, 2) - for data.
' Columns
' UBound(vntR, 2) - for Repeat Array Columns.
' 1 - for unique values.
' 1 - for Unique Header Row.
ReDim vntT(1 To 1 + NoR * UBound(vntU, 2), _
1 To UBound(vntR, 2) + 1 + 1)
' Write Headers to Header Array.
vntH = Split(cHeaders, ",")
' Write Headers to Target Array.
For j = 1 To UBound(vntT, 2)
vntT(1, j) = Trim(vntH(j - 1))
Next
' Repeat Array to Target Array
CUR = CUR + 1 ' Calculate Current Column in Target Array.
i = 1 ' First row of Target Array contains Headers.
' Task: Write values of current rows (k) in columns (j) in Repeat Array
' to current rows (i) in columns (j + CUR - 1) of Target Array as many
' times as there are columns (m) in Unique Array.
For k = 1 To UBound(vntR) ' Rows of Repeat Array
For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
i = i + 1 ' Count current row of Target Array.
For j = 1 To UBound(vntR, 2) ' Columns of Repeat Array
' Write value of current record in Repeat Array
' to current record of Target Array.
vntT(i, j + CUR - 1) = vntR(k, j)
Next
Next
Next
' Unique Array to Target Array
CUR = CUR + UBound(vntR, 2) ' Calculate Current Column in Target Array.
i = 1 ' First row of Target Array contains Headers.
' Task: Write values of current row (k) and current column (m) of Unique
' Array each to the next row (i) in current column (CUR) of Target Array.
For k = 1 To UBound(vntU) ' Rows of Unique Array
For m = 1 To UBound(vntU, 2) ' Columns of Unique Array
i = i + 1 ' Count current row of Target Array.
' Write value of current record in Unique Array
' to current record of Target Array.
vntT(i, CUR) = vntU(k, m)
Next
Next
' Unique Header Array to Target Array
CUR = CUR + 1 ' Calculate Current Column in Target Array.
i = 1 ' First row of Target Array contains Headers.
' Task: Write values of current column (m) of Unique Header Array each
' to the next row (i) in current column (CUR) of Target Array as many
' times as there are rows(k) in Unique Array.
For k = 1 To UBound(vntU) ' Rows of Unique Array
For m = 1 To UBound(vntUH, 2) ' Columns of Unique Header Array
i = i + 1 ' Count current row of Target Array.
' Write value of current record in Unique Array
' to current record of Target Array.
vntT(i, CUR) = vntUH(1, m)
Next
Next
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget).Range(cFCell)
' Clear contents of Target Range and the range below it.
.Resize(.Parent.Rows.Count - .Parent.Range(cFCell).Row + 1, _
UBound(vntT, 2)).ClearContents
' Copy Target Array to Target Range.
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Answer 2

You could just loop through the names, and output them in a column.
Something like the following maybe:
Option Explicit
Sub sort()
Dim rArea As Range, lRow As Long, oCN As Long, outCol As String, cell As Range
'Set this to the range of names
Set rArea = ActiveSheet.Range("C2:G4")
'Set this to output
outCol = "J"
oCN = Columns(outCol).Column
For Each cell In rArea
lRow = ActiveSheet.Range(outCol & ActiveSheet.Rows.Count).End(xlUp).Row 'Update last row in output column
Cells(lRow + 1, oCN).Value = cell.Value 'Print Name
Cells(lRow + 1, oCN - 1).Value = Cells(cell.Row, 2).Value 'Print Company
Next cell
End Sub
I made some last minute changes for dynamics. But compare with the picture, and you should be able to figure out what I'm doing.
I don't see the point to adding the other rows with a macro, but you can do that as well obviously.