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,
Adjust the values in the constants section to fit your needs.
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.
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 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 
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.
