XL 2010 formule tableau excel

Sub Nouveau_tableau()
Dim tablo, d As Object, d1 As Object, d2 As Object, i&, s, x$, maxi%
'---analyse du tableau source---
tablo = Feuil1.UsedRange.Resize(, 10) 'matrice, plus rapide, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 4 To UBound(tablo)
    s = Split(tablo(i, 1))
    If UBound(s) > 0 Then
        x = s(0) & " " & s(1)
        d(x) = IIf(d.exists(x), d(x), x) & Chr(1) & tablo(i, 6) & Chr(1) & tablo(i, 7) 'concaténation
        d1(x) = d1(x) + 1 'comptage
        d2(x) = tablo(i, 10) 'valeur en dernière ligne
    End If
Next
'---tableau des résultats---
Application.ScreenUpdating = False
With Feuil2 'CodeName de la feuille
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1].CurrentRegion.Offset(1)
        .ClearContents 'RAZ
        If .Columns.Count > 3 Then .Columns(3).EntireColumn.Resize(, .Columns.Count - 3).Delete 'racourcissement à 3 colonnes
        If d.Count Then
            maxi = Application.Max(d1.items)
            .Columns(2).EntireColumn.Resize(, 2 * maxi - 1).Insert 'insertion des colonnes nécessaire
            .Columns(1).Resize(d.Count) = Application.Transpose(d.items) 'Transpose est limitée à 65536 lignes
            .Columns(1).Resize(d.Count).TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
            .Columns(2 * maxi + 2).Resize(d.Count) = Application.Transpose(d2.items)
            For i = 2 To 2 * maxi Step 2: .Columns(i).EntireColumn.HorizontalAlignment = xlCenter: Next 'centrage
        End If
    End With
    .Columns.AutoFit 'ajustement largeur
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
End Sub

Sub Nouveau_tableau()
Dim tablo, d As Object, d1 As Object, d2 As Object, i&, s, x$, maxi%, a, b, ubc%, c(), j%
'---analyse du tableau source---
tablo = Feuil1.UsedRange.Resize(, 10) 'matrice, plus rapide, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For i = 4 To UBound(tablo)
    s = Split(tablo(i, 1))
    If UBound(s) > 0 Then
        x = s(0) & " " & s(1)
        d(x) = IIf(d.exists(x), d(x), x) & Chr(1) & tablo(i, 6) & Chr(1) & tablo(i, 7) 'concaténation
        d1(x) = d1(x) + 1 'comptage
        d2(x) = tablo(i, 10) 'valeur en dernière ligne
    End If
Next i
'---tableau des résultats---
Application.ScreenUpdating = False
With Feuil2 'CodeName de la feuille
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[A1].CurrentRegion.Offset(1)
        .ClearContents 'RAZ
        If .Columns.Count > 3 Then .Columns(3).EntireColumn.Resize(, .Columns.Count - 3).Delete 'racourcissement à 3 colonnes
        If d.Count Then
            maxi = Application.Max(d1.items)
            .Columns(2).EntireColumn.Resize(, 2 * maxi - 1).Insert 'insertion des colonnes nécessaires
            a = d.items: b = d2.items
            ubc = 2 * maxi + 1
            ReDim c(d.Count - 1, ubc) 'base 0
            For i = 0 To UBound(b)
                c(i, ubc) = b(i) 'dernière colonne
                s = Split(a(i), Chr(1))
                For j = 0 To UBound(s)
                    c(i, j) = s(j)
            Next j, i
            .Columns(1).Resize(d.Count, ubc + 1) = c
            For i = 2 To 2 * maxi Step 2: .Columns(i).EntireColumn.HorizontalAlignment = xlCenter: Next 'centrage
        End If
    End With
    .Columns.AutoFit 'ajustement largeur
    With .UsedRange: End With 'actualise les barres de défilement
    .Activate 'facultatif
End With
End Sub

Private Sub Worksheet_Activate()
Nouveau_tableau 'lance la macro
End Sub