[Solved] Transpose Column into Row with VBA [closed]

Question

This is not so straightforward a problem because of having to consolidate the information by date.

You also do not indicate what you want to happen should there be more than one identical code associated with a particular date. I chose to ignore it, and only list the unique codes, but you can modify the code below to do something else, if you need.

Simplified algorithm:

Read the data into a VBA array (for speed of processing)
Create User Defined Objects (class) with properties of:
- the relevant date
- a collection (dictionary) of all the codes associated with that date
Collect these objects into another dictionary with the Key being the relevant date
Reorder the information into a “Results” array
output to the worksheet and format.

Read the notes in the code, as they are quite important

Class Module

'**Rename this Module:  cByDates**

Option Explicit

Private pDt As Date
Private pCode As String
Private pCodes As Dictionary

Public Property Get Dt() As Date
    Dt = pDt
End Property
Public Property Let Dt(Value As Date)
    pDt = Value
End Property

Public Property Get Code() As String
    Code = pCode
End Property
Public Property Let Code(Value As String)
    pCode = Value
End Property

Public Property Get Codes() As Dictionary
    Set Codes = pCodes
End Property
Public Function addCodesItem(Value)
    'bypass any duplicates
    If Not Codes.Exists(Value) Then _
    Codes.Add Value, Value
End Function

Private Sub Class_Initialize()
    Set pCodes = New Dictionary
        pCodes.CompareMode = TextCompare
End Sub

Regular Module

'Set Reference to Microsoft Scripting Runtime

Option Explicit

Sub ConsolidateByDate()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cBD As cByDates, dBD As Dictionary
    Dim I As Long, J As Long
    Dim lRC() As Long 'last row-col
    Dim V As Variant, W As Variant

'Setup worksheets and results range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'read original data into VBA array for speed of processing
'if there is or will be other information on Sheet1, then you will need a
'   different routine to find the last row and column
With wsSrc
    lRC = LastRowCol(.Name)
    vSrc = .Range(.Cells(1, 1), .Cells(lRC(0), lRC(1)))
End With

'Collect and organize the data
Set dBD = New Dictionary
For I = 1 To UBound(vSrc, 1)
    For J = 2 To UBound(vSrc, 2)
        Set cBD = New cByDates
        With cBD
            .Dt = vSrc(I, 1)
            .Code = vSrc(I, J)
            .addCodesItem .Code

            If Not dBD.Exists(.Dt) Then
                dBD.Add Key:=.Dt, Item:=cBD
            Else
                dBD(.Dt).addCodesItem .Code
            End If
        End With
    Next J
Next I

'Create results array
'number of columns = number of dBD items
lRC(0) = 0
lRC(1) = dBD.Count

'number of rows = max codes count
For Each V In dBD.Keys
    lRC(0) = IIf(lRC(0) > dBD(V).Codes.Count, lRC(0), dBD(V).Codes.Count)
Next V

ReDim vRes(0 To lRC(0), 1 To lRC(1))

'Populate each column
J = 1
For Each V In dBD.Keys
    I = 0
    vRes(I, J) = V
    For Each W In dBD(V).Codes.Keys
        I = I + 1
        vRes(I, J) = W
    Next W
    J = J + 1
Next V

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

'------------------------------------------------------
Function LastRowCol(Worksht As String) As Long()
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

Original Data

Results

I try to avoid references to non-SO information, but I will make an exception here. For a basic discussion of Classes, see Chip Pearson’s Introduction to Classes

Accepted Answer