VBA: transpose the table with dates - excel

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

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,"")

Answer 3

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