Power Query Retravailler des données à l'origine en ligne pour les mettre en colonne

Private Sub Worksheet_Activate()
Dim ncol%, deb As Date, dDate As Object, col%, d As Object, tablo, i&, x$, resu(), a, b, n&, dd As Object, lig&, s
ncol = 21 'nombre de colonnes du tableau des résultats
deb = CDate("1/2/2020") 'date de début
'---liste des dates---
Set dDate = CreateObject("Scripting.Dictionary")
For col = 7 To ncol
    dDate(DateSerial(Year(deb), Month(deb) + col - 7, 1)) = col 'mémorise la colonne
Next
'---liste des numéros dossier sans doublon---
Set d = CreateObject("Scripting.Dictionary")
With Sheets("liste avec aide")
    tablo = .Range(.ListObjects(1).Name).Resize(, 6) 'matrice, plus rapide
End With
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If x <> "" Then d(x) = tablo(i, 2) 'mémorise la société
Next
If d.Count = 0 Then GoTo 1
ReDim resu(1 To 4 * d.Count, 1 To ncol) 'tableau des résultats
a = d.keys: b = d.items
'---résultats colonnes 1 2 6---
For i = 1 To UBound(resu) Step 4
    resu(i, 1) = a(n): resu(i, 2) = b(n): resu(i, 6) = "Aide au paiement Covid 1"
    resu(i + 1, 1) = a(n): resu(i + 1, 2) = b(n): resu(i + 1, 6) = "Exonération Covid 1"
    resu(i + 2, 1) = a(n): resu(i + 2, 2) = b(n): resu(i + 2, 6) = "Aide au paiement Covid 2"
    resu(i + 3, 1) = a(n): resu(i + 3, 2) = b(n): resu(i + 3, 6) = "Exonération Covid 2"
    n = n + 1
Next
'---résultats colonnes des dates---
Set dd = CreateObject("Scripting.Dictionary")
dd.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(resu)
    dd(resu(i, 1) & resu(i, 6)) = i 'mémorise la ligne
Next
For i = 1 To UBound(tablo)
    x = tablo(i, 1) & Trim(tablo(i, 5))
    If dd.exists(x) Then
        lig = dd(x)
        col = dDate(tablo(i, 4))
        If col And IsNumeric(CStr(tablo(i, 6))) Then resu(lig, col) = resu(lig, col) + CDbl(tablo(i, 6))
    End If
Next
'---résultats colonnes 3 4 5---
With Sheets("liste avec coll")
    tablo = .Range(.ListObjects(1).Name).Resize(, 10) 'matrice, plus rapide
End With
For i = 1 To UBound(tablo)
    x = tablo(i, 1)
    If d.exists(x) Then d(x) = tablo(i, 7) & Chr(1) & tablo(i, 8) & Chr(1) & tablo(i, 10)
Next
For i = 1 To UBound(resu)
    s = Split(d(resu(i, 1)), Chr(1))
    resu(i, 3) = s(0): resu(i, 4) = s(1): resu(i, 5) = s(2)
Next
'---restitution---
1 Application.ScreenUpdating = False
On Error Resume Next
With Range(ListObjects(1).Name)
    .Delete xlUp 'RAZ
    .Resize(UBound(resu)) = resu
End With
End Sub