Home » excel » Rearranging cells Excel VBA

Rearranging cells Excel VBA

Posted by: admin May 14, 2020 Leave a comment

Questions:

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:

input

and with this data, I’m trying to get this output:

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,

How to&Answers:

Transpose Data (Rearrange)

Adjust the values in the constants section to fit your needs.

Links

Workbook Download (Dropbox)

Images

Source (Sheet1)

enter image description here

Target 1 (Sheet2)

enter image description here

Target 2 (Sheet3)

enter image description here

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:

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.

enter image description here

I don’t see the point to adding the other rows with a macro, but you can do that as well obviously.