VBA: transpose the table with dates

Question

I'm novice in VBA. I'm trying to transpose my data:

I would like to have this results:

I tried all day the methodes like: Resize(UBound(Table2, 1), UBound(Table2, 2)) = Table2, Application.transpose(Tbl1) but I don't have the diserid result. Could you help me please? Thank you very much!

Answer 1

A Power Query Solution (CVR)

Added corrections; credits to Ron Rosenfeld.

• Click into your table.
• Select Data > From Table/Range: The Power Query Editor opens containing your data.
• The first columns is selected. If not, click the header of your first column (Date) to select it.
• Select Transform > Pivot Column: The Pivot Column window opens.
• In the Values Column combo box the second column (Values) is already selected. If not, select it.
• Click Advanced Options where Sum is already selected which will sum multiple entries for the same ID/Date columns. If not, select it.
• Press OK. The data is transformed.
• Select Home > Close & Load: The Power Query Editor closes and the transformed data is presented in a table in a new worksheet.

Short Version

• Click into your table.
• Select Data > From Table/Range: The Power Query Editor opens containing your data.
• Select Transform > Pivot Column: The Pivot Column window opens.
• Press OK. The data is transformed.
• Select Home > Close & Load: The Power Query Editor closes and the transformed data is presented in a table in a new worksheet.

Answer 2

Pivot CVR

• CVR: Column Labels, Values, Row Labels.
• It is assumed that the initial data, the Source Range, contains a row of headers, whose third cell value will be copied to the first cell of the resulting data, the Destination Range.
• Adjust the values in the constants section.
• Copy the complete code to a standard module, e.g. Module1.
• Only run the first procedure, pivotDataCVR, the other two are being called by it, when necessary.
• A similar solution, which I based this solution on, although RCV, can be found here.

The Code

Option Explicit

Sub pivotDataCVR()
    
    ' Define constants.
    Const srcName As String = "Sheet1"
    Const srcFirst As String = "A1"
    Const dstName As String = "Sheet2"
    Const dstFirst As String = "A1"
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Source First Cell Range.
    Dim cel As Range
    Set cel = wb.Worksheets(srcName).Range(srcFirst)
    ' Define Source Range.
    Dim rng As Range
    With cel.CurrentRegion
       Set rng = cel.Resize(.Rows.Count + .Row - cel.Row, _
           .Columns.Count + .Column - cel.Column)
    End With
    
    ' Get unique values.
    Dim dts As Variant
    dts = getUniqueColumn1D(rng.Columns(1).Resize(rng.Rows.Count - 1).Offset(1))
    sort1D dts
    Dim idx As Variant
    idx = getUniqueColumn1D(rng.Columns(3).Resize(rng.Rows.Count - 1).Offset(1))
    sort1D idx
    
    ' Write values from Source Range to Source Array.
    Dim Source As Variant
    Source = rng.Value
    
    ' Define Destination Array.
    Dim Dest As Variant
    ReDim Dest(1 To UBound(idx) - LBound(idx) + 2, _
        1 To UBound(dts) - LBound(dts) + 2)
    
    ' Write values from arrays to Destination Array.
    Dest(1, 1) = Source(1, 3)
    Dim n As Long
    Dim i As Long
    i = 1
    For n = LBound(idx) To UBound(idx)
        i = i + 1
        Dest(i, 1) = idx(n)
    Next n
    Dim j As Long
    j = 1
    For n = LBound(dts) To UBound(dts)
        j = j + 1
        Dest(1, j) = dts(n)
    Next n
    For n = 2 To UBound(Source, 1)
        i = Application.Match(Source(n, 3), idx, 0) + 1
        j = Application.Match(Source(n, 1), dts, 0) + 1
        Dest(i, j) = Source(n, 2)
    Next n
            
    ' Define Destination First Cell Range.
    Set cel = wb.Worksheets(dstName).Range(dstFirst)
    ' Define Destination Range.
    Set rng = cel.Resize(UBound(Dest, 1), UBound(Dest, 2))
    
    ' Write from Destination Array to Destination Range.
    rng.Value = Dest
            
    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"
    
End Sub

' Returns the unique values from a column range in a 1D array.
Function getUniqueColumn1D(ColumnRange As Range, _
                           Optional ByVal Sorted As Boolean = False) _
         As Variant
    Dim Data As Variant
    Data = ColumnRange.Columns(1).Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        Dim Key As Variant
        Dim i As Long
        For i = 1 To UBound(Data, 1)
            Key = Data(i, 1)
            If Not IsError(Key) And Not IsEmpty(Key) Then
                .Item(Key) = Empty
            End If
        Next i
        If .Count > 0 Then
            getUniqueColumn1D = .Keys
        End If
    End With
End Function

' Sorts a 1D array only if it contains values of the same data type.
Sub sort1D(ByRef OneD As Variant, _
           Optional ByVal Descending As Boolean = False)
    With CreateObject("System.Collections.ArrayList")
        Dim i As Long
        For i = LBound(OneD) To UBound(OneD)
            .Add OneD(i)
        Next i
        .Sort
        If Descending Then
            .Reverse
        End If
        OneD = .ToArray
    End With
End Sub

Answer 3

With Office365 you can use below formulas (as per my screenshot).

F2=UNIQUE(C1:C11)
G1=TRANSPOSE(SORT(UNIQUE(A1:A10)))
G2=FILTER($B$1:$B$11,($C$1:$C$11=$F2)*($A$1:$A$11=G$1),"")

After putting FILTER() formula to G2 cell drag across right and down as needed.

You can also use XLOOKUP() instead of FILTER() formula to G2 like-

=XLOOKUP(1,($A$1:$A$11=G$1)*($C$1:$C$11=$F2),$B$1:$B$11,"")