Inversion d'un tableau via dictionnaire VBA (pas de PQuery ou tcd)

Bonjour

Je voudrais via les dictionnaires que je ne maitrise pas (encore moins dans ce cas précis) mettre ce tableau à gauche en un ordre <> tel que celui en gris /vert.

Le seul résultat que j'ai obtenu est le total dans la zone orange mais je n'arrive pas à remplir la zone verte.

Ce serait sympa de commenter le code ajouté au mien

P.

Bonjour Patrick,

Avant de coder, quelques précisions importantes :

1/ tes tableaux sont ils des listes simples de données ou bien des tableaux structurés ?

2/ tu veux donc un tableau de résultat comme suit : tableau à double entrée avec somme des valeurs, sans distinction ou filtre de date ?

Bonjour,

Peu importe la date dans le tableau final ( pas besoin ) et le tableau est un TS oui mais s'il ne l'est pas, le code devait aussi fonctionner je pense non ?

Autant travailler avec ce qui est le plus souvent représenté, soit le TS :)

Merci !

Bien plus rigoureux de travailler avec un TS. La liste "plate" n'est pas interdite mais ne sert pas forcément les mêmes ambitions.

1 - Je peux partir sur un full paramétrable : Sub TransformerTableauFiltré(rngStart As Range, rngResult As Range, colNoms As Range, rngTaches As Range, _
Optional colDate As Range, Optional dateDebut As Variant, Optional dateFin As Variant)

2 - Ou bien une version simplifiée Sub TransformerTableauFiltré(rngStart As Range, rngResult As Range, colNoms As Range, rngTaches As Range)

→ ton choix ?

Edit : si on part sur un TS source et un TS résultat (cela m'arrange bien d'ailleurs) et on aurait plutôt un appel de procédure comme ca : Sub TransformerTableauFiltré(TSsource As ListObject, TSresult As ListObject, colNoms As Range, rngTaches As Range)

Version 1 je dirais mais... rien ne presse , prends ton temps pour ton codage :)

Merci !

Pars là dessus, et dis moi ce que ca sort ? Pas le temps de tester je dois filer...

Option Explicit

Private Const ENTETE_TACHE As String = "Tâche"

Sub TransformerTableauFiltré(TSsource As ListObject, TSresult As ListObject, _
    colNoms As Range, rngTaches As Range)

    On Error GoTo GestionErreur

    Dim dict As Object, nomsUniques As Object, tachesUniques As Object
    Dim ligne As ListRow, col As ListColumn
    Dim nom, tache, somme As Double, key$
    Dim ws As Worksheet
    Dim i&, j&

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    ' === 1. Sécurités de base ===
    If TSsource Is Nothing Then MsgBox "Tableau source non défini.", vbCritical: Exit Sub
    If TSresult Is Nothing Then MsgBox "Tableau résultat non défini.", vbCritical: Exit Sub
    If colNoms Is Nothing Then MsgBox "Colonne des noms non définie.", vbCritical: Exit Sub
    If rngTaches Is Nothing Then MsgBox "Plage des tâches non définie.", vbCritical: Exit Sub
    If TSsource.DataBodyRange Is Nothing Then MsgBox "Le tableau source est vide.", vbExclamation: Exit Sub

    ' === 2. Vérification si résultat contient déjà des données ===
    With TSresult
        If Not .ListColumns Is Nothing Then
            If .ListColumns.Count > 0 Then
                Dim reponse As VbMsgBoxResult
                reponse = MsgBox("Le tableau résultat contient déjà des données." & vbCrLf & _
                                 "Voulez-vous le recréer complètement ?", vbYesNo + vbQuestion, "Confirmation")
                If reponse = vbNo Then Exit Sub
                ' Supprime toutes les colonnes existantes
                Do While .ListColumns.Count > 0
                    .ListColumns(1).Delete
                Loop
            End If
        End If
    End With

    ' === 3. Initialisations ===
    Set dict = CreateObject("Scripting.Dictionary")
    Set nomsUniques = CreateObject("Scripting.Dictionary")
    Set tachesUniques = CreateObject("Scripting.Dictionary")
    Set ws = TSresult.Parent

    ' === 4. Lecture et agrégation ===
    For Each ligne In TSsource.ListRows
        nom = ligne.Range.Cells(1, colNoms.Column - TSsource.Range.Columns(1).Column + 1).Value
        If Len(Trim(nom)) > 0 Then
            If Not nomsUniques.exists(nom) Then nomsUniques.Add nom, True
            For Each col In TSsource.ListColumns
                If Not Intersect(col.DataBodyRange, rngTaches) Is Nothing Then
                    tache = col.Name
                    If Not tachesUniques.exists(tache) Then tachesUniques.Add tache, True
                    somme = ligne.Range.Cells(1, col.Index).Value
                    If IsNumeric(somme) Then
                        key = nom & "_" & tache
                        If Not dict.exists(key) Then dict.Add key, 0
                        dict(key) = dict(key) + somme
                    End If
                End If
            Next col
        End If
    Next ligne

    ' === 5. Construction du tableau de sortie en mémoire ===
    Dim nbTaches&, nbNoms&
    nbTaches = tachesUniques.Count
    nbNoms = nomsUniques.Count

    Dim data() As Variant
    ReDim data(0 To nbTaches, 0 To nbNoms) ' Ligne 0 = headers, colonnes 0..n

    ' Ligne des en-têtes
    data(0, 0) = ENTETE_TACHE
    j = 1
    For Each nom In nomsUniques.Keys
        data(0, j) = nom
        j = j + 1
    Next nom

    ' Corps du tableau
    i = 1
    For Each tache In tachesUniques.Keys
        data(i, 0) = tache
        j = 1
        For Each nom In nomsUniques.Keys
            key = nom & "_" & tache
            If dict.exists(key) Then
                data(i, j) = dict(key)
            Else
                data(i, j) = 0
            End If
            j = j + 1
        Next nom
        i = i + 1
    Next tache

    ' === 6. Écriture dans le tableau résultat ===
    Dim target As Range
    Set target = TSresult.Range.Cells(1, 1)

    ' Redimension du ListObject (colonnes + lignes)
    Dim nbCols&, nbRows&
    nbCols = nbNoms + 1
    nbRows = nbTaches + 1

    ' Recrée la structure complète du tableau résultat
    Set TSresult = ws.ListObjects.Add(xlSrcRange, target.Resize(nbRows, nbCols), , xlYes)
    TSresult.Name = TSresult.Name ' évite renommage forcé

    ' Écriture des données d’un coup
    TSresult.Range.Value = data

    ' Mise en forme
    TSresult.Range.Columns.AutoFit

    MsgBox "Transformation terminée avec succès !", vbInformation
    GoTo LIBERATION

GestionErreur:
    MsgBox "Erreur " & Err.Number & " dans TransformerTableauFiltré : " & Err.Description, vbCritical

LIBERATION:
    Set dict = Nothing: Set nomsUniques = Nothing: Set tachesUniques = Nothing
    Set ws = Nothing: Set target = Nothing: Set TSresult = Nothing
    Set ligne = Nothing: Set col = Nothing

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

Je regarde ça lundi, je dois aussi partir

Merci !

Hello,

tomato a écrit :

Option Explicit

Private Const ENTETE_TACHE As String = "Tâche"

Sub TransformerTableauFiltré(TSsource As ListObject, TSresult As ListObject, _
    colNoms As Range, rngTaches As Range)

    On Error GoTo GestionErreur

    Dim dict As Object, nomsUniques As Object, tachesUniques As Object
    Dim ligne As ListRow, col As ListColumn
    Dim nom, tache, somme As Double, key$
    Dim ws As Worksheet
    Dim i&, j&

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    ' === 1. Sécurités de base ===
    If TSsource Is Nothing Then MsgBox "Tableau source non défini.", vbCritical: Exit Sub
    If TSresult Is Nothing Then MsgBox "Tableau résultat non défini.", vbCritical: Exit Sub
    If colNoms Is Nothing Then MsgBox "Colonne des noms non définie.", vbCritical: Exit Sub
    If rngTaches Is Nothing Then MsgBox "Plage des tâches non définie.", vbCritical: Exit Sub
    If TSsource.DataBodyRange Is Nothing Then MsgBox "Le tableau source est vide.", vbExclamation: Exit Sub

    ' === 2. Vérification si résultat contient déjà des données ===
    With TSresult
        If Not .ListColumns Is Nothing Then
            If .ListColumns.Count > 0 Then
                Dim reponse As VbMsgBoxResult
                reponse = MsgBox("Le tableau résultat contient déjà des données." & vbCrLf & _
                                 "Voulez-vous le recréer complètement ?", vbYesNo + vbQuestion, "Confirmation")
                If reponse = vbNo Then Exit Sub
                ' Supprime toutes les colonnes existantes
                Do While .ListColumns.Count > 0
                    .ListColumns(1).Delete
                Loop
            End If
        End If
    End With

    ' === 3. Initialisations ===
    Set dict = CreateObject("Scripting.Dictionary")
    Set nomsUniques = CreateObject("Scripting.Dictionary")
    Set tachesUniques = CreateObject("Scripting.Dictionary")
    Set ws = TSresult.Parent

    ' === 4. Lecture et agrégation ===
    For Each ligne In TSsource.ListRows
        nom = ligne.Range.Cells(1, colNoms.Column - TSsource.Range.Columns(1).Column + 1).Value
        If Len(Trim(nom)) > 0 Then
            If Not nomsUniques.exists(nom) Then nomsUniques.Add nom, True
            For Each col In TSsource.ListColumns
                If Not Intersect(col.DataBodyRange, rngTaches) Is Nothing Then
                    tache = col.Name
                    If Not tachesUniques.exists(tache) Then tachesUniques.Add tache, True
                    somme = ligne.Range.Cells(1, col.Index).Value
                    If IsNumeric(somme) Then
                        key = nom & "_" & tache
                        If Not dict.exists(key) Then dict.Add key, 0
                        dict(key) = dict(key) + somme
                    End If
                End If
            Next col
        End If
    Next ligne

    ' === 5. Construction du tableau de sortie en mémoire ===
    Dim nbTaches&, nbNoms&
    nbTaches = tachesUniques.Count
    nbNoms = nomsUniques.Count

    Dim data() As Variant
    ReDim data(0 To nbTaches, 0 To nbNoms) ' Ligne 0 = headers, colonnes 0..n

    ' Ligne des en-têtes
    data(0, 0) = ENTETE_TACHE
    j = 1
    For Each nom In nomsUniques.Keys
        data(0, j) = nom
        j = j + 1
    Next nom

    ' Corps du tableau
    i = 1
    For Each tache In tachesUniques.Keys
        data(i, 0) = tache
        j = 1
        For Each nom In nomsUniques.Keys
            key = nom & "_" & tache
            If dict.exists(key) Then
                data(i, j) = dict(key)
            Else
                data(i, j) = 0
            End If
            j = j + 1
        Next nom
        i = i + 1
    Next tache

    ' === 6. Écriture dans le tableau résultat ===
    Dim target As Range
    Set target = TSresult.Range.Cells(1, 1)

    ' Redimension du ListObject (colonnes + lignes)
    Dim nbCols&, nbRows&
    nbCols = nbNoms + 1
    nbRows = nbTaches + 1

    ' Recrée la structure complète du tableau résultat
    Set TSresult = ws.ListObjects.Add(xlSrcRange, target.Resize(nbRows, nbCols), , xlYes)
    TSresult.Name = TSresult.Name ' évite renommage forcé

    ' Écriture des données d’un coup
    TSresult.Range.Value = data

    ' Mise en forme
    TSresult.Range.Columns.AutoFit

    MsgBox "Transformation terminée avec succès !", vbInformation
    GoTo LIBERATION

GestionErreur:
    MsgBox "Erreur " & Err.Number & " dans TransformerTableauFiltré : " & Err.Description, vbCritical

LIBERATION:
    Set dict = Nothing: Set nomsUniques = Nothing: Set tachesUniques = Nothing
    Set ws = Nothing: Set target = Nothing: Set TSresult = Nothing
    Set ligne = Nothing: Set col = Nothing

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

@patrick, je respecte ton choix de ne pas choisir Power Query

Pour info, voici ce que ça donnerait en langage M :

let
    Source = Table.RemoveColumns(Excel.CurrentWorkbook(){[Name="Tableau1"]}[Content],{"Jour par Tâche"}),
    UnPivot = Table.UnpivotOtherColumns(Source, {"Noms"}, "Tâches", "Valeur"),
    Pivot = Table.Pivot(UnPivot, List.Distinct(UnPivot[Noms]), "Noms", "Valeur", List.Sum)
in
    Pivot

Bonne soirée, et bon W-E

Je n'utilise jamais donc je ne sais même pas où coller ton texte...

Tu sais me dire comment insérer ça dans mon tableau ?

Ceci dit, ça semble être top !

Merci !

Re-,

Tu sélectionnes une des cellules du tableau de données (que tu as nommé "Tableau1")

Dans le ruban "Données", tu cliques sur "A partir d'un tableau"

L'éditeur Power Query va s'ouvrir, avec une interface ressemblant fortement à un ruban Excel...

Et tu verras ton tableau, avec sans doute une modification de type des données, et un truc qui ressemble à ça :

A gauche, tu as la requête (Tableau1), et à droite, les étapes

Si tu cliques sur "Éditeur avancé", tu pourras lire le code généré automatiquement (comme si tu enregistrais une macro)

Tu remplaces tout le code qui apparait par le code que je t'ai donné dans mon post précédent, puis tu cliques sur "Fermer et charger"...

Attention, ce code a fait l'objet de modifications manuelles de ma part, mais tout aurait pu être obtenu à la souris, via cet éditeur PQ

Vu dans ta signature, (outre ton âge...), ta passion de progresser (et j'ai presque le même âge, et cette même passion)

N'aies surtout pas peur, tu ne peux rien faire d’irréparable avec l'éditeur, les données ne sont jamais impactées, juste le résultat

Pour exemple, le fichier qui m'a servi

Bonne découverte d'un nouveau monde :)

J'y regarderai !

Et je te donnerai mon opinion :)

Merci

Bonjour patrick1957, à tous,

Voici ma p'tite version.

On utilise deux dictionary: un pour les noms et l'autre pour les tâches. Le résultat est le tableau source transposé.

Ce tableau résultat aura en ligne les tâches et en colonne les noms. Il faut pour chaque valeur de la source repérée par son nom et par sa tâche savoir où placer cette valeur (en fait additionner) dans le tableau résultat. C'est à cela que vont servir les deux dictionary.

• Le premier nom sera introduit dans le dictionary des noms avec pour clef ce premier nom (key) et pour indice 1 (item). Si ce nom est rencontré une autre fois, on ne fait aucun traitement pour garantir l'unicité de l'indice.
• Le deuxième nom sera introduit dans le dictionary des noms avec pour clef ce deuxième nom (key) et pour indice 2 (item). Si ce nom est rencontré une autre fois, on ne fait aucun traitement pour garantir l'unicité de l'indice.
• Le troisième nom sera introduit dans le dictionary des noms avec pour clef ce troisième nom (key) et pour indice 3 (item). Si ce nom est rencontré une autre fois, on ne fait aucun traitement pour garantir l'unicité de l'indice.

Le dictionary des noms donnera pour chacun des noms son indice. C'est une méthode classique pour relier directement un élément à la place qu'il occupe. Si on a le nom "toto" alors dicoNom("toto") donnera directement son indice.

Évidemment si le tableau résultat a une ou des lignes de titres et une ou des colonnes de titres alors les indices seront adaptés en conséquence.

Donc on utilise un tableau des valeurs sources, un tableau pour le tableau transposé, un dictionary pour les indices de lignes (tâches) et un dictionary pour les indices de colonnes (noms) et un petit tableau à une ligne pour les totaux.

• Cliquez sur le bouton 'Transposer' de la feuille 'base' pour lancer la macro.
• Le résultat a été déposé sur la feuille 'Res'
• Le code est dans Module1
• Le code est un peu commenté

edit : avec cette méthode, le tableau source n'a pas pas besoin d'être trié.

bonjour Patrick1957,Cousinhub,

Edit : + Tomato et MaFraise, désolé

mon essai

Sub test()
     Dim Arr, i, j, Dict, Temp, N, s, sp, r

     Set Dict = CreateObject("scripting.dictionary")     'votre dictionaire
     Dict.comparemode = vbTextCompare        'ignorer majuscules/miniscules

     With Sheets("Base")                     'votre feuille
          Arr = .Range("A5").CurrentRegion.Value2     'données >>> matrice
          For i = 2 To UBound(Arr)           'boucler les noms (sans l'entete)
               If InStr(1, s, Arr(i, 2), 1) = 0 Then s = s & Chr(1) & Arr(i, 2)     'string avec les noms uniques
          Next
          If Len(s) = 0 Then MsgBox "erreur": Exit Sub     'aucun nom ??? EXIT
          sp = Split(s, Chr(1))              'splitter ces noms
          Dict("entete") = sp                'premier key avec item ces noms

          For j = 3 To UBound(Arr, 2)        'boucler les taches
               If Dict.exists(Arr(1, j)) Then     'tache existe déjà ?
                    MsgBox "doublon : " & Arr(1, j)     'problème
               Else                          'nouveau tache
                    ReDim Temp(1 To UBound(sp) + 1)     'RAZ matrice temporaire (base 1)
                    Temp(1) = Arr(1, j)      '1ier élément = nom de la tache
                    For i = 2 To UBound(Arr)     'boucler les noms (sans l'entete)
                         r = Application.IfError(Application.Match(Arr(i, 2), sp, 0), 0)     'chercher nom dans sp
                         If r = 0 Then       'nom inconnu (normallement impossible)
                              MsgBox "erreur"
                         Else
                              Temp(r) = Temp(r) + Arr(i, j)     'cumuler dans la matrice Temp
                         End If
                    Next
                    Dict(Arr(1, j)) = Temp   'écrire matrice comme item dans le dictionaire, clé = la tache
               End If
          Next

          N = Dict.Count                     'nombre de clés
          If N = 0 Then                      'normallement impossible, parce qu'on a toujours l'entete ici
               MsgBox "vide"
          Else
               If N = 1 Then Dict("dummy") = Dict.items()(0)     'cas spécial, dictionaire avec 1 clé = ajouter un dummy, autrement problèmes avec "application.index"
               With .Range("AG1").Resize(N, UBound(sp) + 1)     'plage pour coller le résultat avec N lignes (=sans dummy)
                    .Value = Application.Index(Dict.items, 0, 0)
                    .EntireColumn.AutoFit
               End With
          End If
     End With

End Sub

Hi,

Hello les vbaïstes inconditionnels...

La demande était pourtant claire, je l'ai "outrepassée"... désolé

@patrick1957, je ne vais surtout pas te conseiller une méthode ou une autre, garde ton option préférée

Un jour, peut-être, VBA "Oupssss"

Salut la compagnie, ca s'active

Mon code initial était faux. Celui-ci est opérationnel.

AppelLaProcédure : vérifie si le tableau résultat existe sur la feuille. Si ce n’est pas le cas, demande à l’utilisateur où le créer, puis appelle la procédure LaProcédure en lui passant le tableau source, le tableau résultat et les plages contenant les noms et les tâches.

LaProcédure : prend un tableau source et calcule, pour chaque nom et chaque tâche, la somme des valeurs associées. Elle construit ensuite un tableau résultat avec les noms en colonnes et les tâches en lignes, remplit les valeurs correspondantes, ajuste les colonnes et affiche un message de confirmation. Elle inclut aussi des vérifications de sécurité et la gestion des erreurs pour éviter les problèmes si le tableau source ou les plages sont vides.

AppelLaProcédure :

Option Explicit

Sub AppelLaProcédure()

    Dim ws As Worksheet
    Dim TSsource As ListObject
    Dim TSresult As ListObject
    Dim colNoms As Range
    Dim rngTaches As Range
    Dim adresseCreation As Range
    Dim tblName As String

    tblName = "tbres" ' <-- nom du tableau résultat

    ' Définir les paramètres
    Set ws = ThisWorkbook.Sheets("Base") ' <-- nom de la feuille source
    Set TSsource = ws.ListObjects("tbsrc") ' <-- nom du TS source
    Set colNoms = ws.Range("B5")    ' <-- plage des noms
    Set rngTaches = ws.Range("C5:K5")  ' <-- plage des tâches

    ' Vérifier si le tableau résultat existe
    On Error Resume Next
    Set TSresult = ws.ListObjects(tblName)
    On Error GoTo 0

    If TSresult Is Nothing Then
        ' Demander à l'utilisateur de sélectionner l'emplacement pour créer le tableau
        MsgBox "Le tableau résultat n'existe pas." & vbCrLf & _
               "Veuillez sélectionner la cellule où créer le tableau", vbInformation

        Set adresseCreation = Application.InputBox("Sélectionnez une cellule" & _
                                        " pour le tableau résultat :", Type:=8)

        ' Créer le tableau avec une seule cellule d'en-tête
        Set TSresult = adresseCreation.Worksheet.ListObjects.Add(xlSrcRange, _
                                        adresseCreation.Resize(1, 1), , xlYes)
        TSresult.Name = tblName
    End If

    ' Appel de la procédure
    Call LaProcédure(TSsource, TSresult, colNoms, rngTaches)
End Sub

LaProcédure :

Option Explicit

Private Const ENTETE_TACHE As String = "Tâches/Noms"

Sub LaProcédure(TSsource As ListObject, TSresult As ListObject, _
    colNoms As Range, rngTaches As Range)

    On Error GoTo GestionErreur

    Dim dict As Object, nomsUniques As Object, tachesUniques As Object
    Dim ligne As ListRow, col As ListColumn
    Dim nom, tache, somme As Double, key$
    Dim i&, j&

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    ' === 1. Sécurités de base ===
    If TSsource Is Nothing Then MsgBox "Tableau source non défini.", vbCritical: Exit Sub
    If TSresult Is Nothing Then MsgBox "Tableau résultat non défini.", vbCritical: Exit Sub
    If colNoms Is Nothing Then MsgBox "Colonne des noms non définie.", vbCritical: Exit Sub
    If rngTaches Is Nothing Then MsgBox "Plage des tâches non définie.", vbCritical: Exit Sub
    If TSsource.DataBodyRange Is Nothing Then MsgBox "Le tableau source est vide.", vbExclamation: Exit Sub

    ' === 2. Vérification si TS résultat contient déjà des données ===
    With TSresult
        If Not .ListColumns Is Nothing Then
            If .ListColumns.Count > 1 Then
                Dim reponse As VbMsgBoxResult
                reponse = MsgBox("Le tableau résultat contient déjà des données." & vbCrLf & _
                                 "Voulez-vous le recréer complètement ?", _
                                 vbYesNo + vbQuestion, "Confirmation")
                If reponse = vbNo Then Exit Sub
                ' Supprime toutes les colonnes sauf la première
                For i = .ListColumns.Count To 2 Step -1
                    .ListColumns(i).Delete
                Next i
            End If
            ' Supprime toutes les lignes sauf l'en-tête
            If .ListRows.Count > 0 Then .DataBodyRange.Delete
        End If
    End With

    ' === 3. Initialisations ===
    Set dict = CreateObject("Scripting.Dictionary")
    Set nomsUniques = CreateObject("Scripting.Dictionary")
    Set tachesUniques = CreateObject("Scripting.Dictionary")

    ' === 4. Lecture et agrégation ===
    For Each ligne In TSsource.ListRows
        nom = ligne.Range.Cells(1, colNoms.Column - TSsource.Range.Columns(1).Column + 1).Value
        If Len(Trim(nom)) > 0 Then
            If Not nomsUniques.exists(nom) Then nomsUniques.Add nom, True
            For Each col In TSsource.ListColumns
                If Not Intersect(col.Range.Cells(1, 1), rngTaches) Is Nothing Then
                    tache = col.Name
                    If Not tachesUniques.exists(tache) Then tachesUniques.Add tache, True
                    somme = ligne.Range.Cells(1, col.Index).Value
                    If IsNumeric(somme) Then
                        key = nom & "_" & tache
                        If Not dict.exists(key) Then dict.Add key, 0
                        dict(key) = dict(key) + somme
                    End If
                End If
            Next col
        End If
    Next ligne

    ' === 5. Construction du header et du body séparés ===
    Dim nbTaches&, nbNoms&
    nbTaches = tachesUniques.Count
    nbNoms = nomsUniques.Count

    Dim header() As Variant: Dim body() As Variant
    ReDim header(1 To nbNoms + 1)
    ReDim body(1 To nbTaches, 1 To nbNoms + 1)

    header(1) = ENTETE_TACHE

    i = 1
    For Each tache In tachesUniques.Keys
        body(i, 1) = tache  ' première colonne = nom de la tâche
        j = 2
        For Each nom In nomsUniques.Keys
            ' Remplir le header
            If i = 1 Then header(j) = nom
            ' Remplir le body
            key = nom & "_" & tache
            If dict.exists(key) Then
                body(i, j) = dict(key)
            Else
                body(i, j) = 0
            End If
            j = j + 1
        Next nom
        i = i + 1
    Next tache

    ' === 6. Écriture dans le tableau résultat ===
    With TSresult
        For i = 1 To UBound(body, 1): .ListRows.Add: Next i
        For j = 2 To UBound(body, 2): .ListColumns.Add: Next j
        .HeaderRowRange.Value = header
        .DataBodyRange.Value = body
        .Range.Columns.AutoFit
    End With

    MsgBox "Transformation terminée avec succès !", vbInformation
    GoTo LIBERATION

GestionErreur:
    MsgBox "Erreur " & Err.Number & " dans TransformerTableauFiltré : " & Err.Description, vbCritical

LIBERATION:
    Set dict = Nothing: Set nomsUniques = Nothing: Set tachesUniques = Nothing
    Set TSresult = Nothing: Set ligne = Nothing: Set col = Nothing

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
End Sub

Edit : correction dans AppelLaProcédure :

    ' Vérifier si le tableau résultat existe
    Dim wsh As Worksheet
    For Each wsh In ThisWorkbook.Worksheets
        On Error Resume Next
        Set TSresult = wsh.ListObjects(tblName)
        On Error GoTo 0
        If Not TSresult Is Nothing Then Exit For
    Next wsh

@tomato, favour personnel, mais je n'aime pas trop "on error goto" et ce "GestionErreur", c'est mieux de les prévenir au lieu de les contourner.

Hi,

BsAlv a écrit :

@tomato, favour personnel, mais je n'aime pas trop "on error goto" et ce "GestionErreur", c'est mieux de les prévenir au lieu de les contourner.

Je ne peux que plussoyer, toute erreur doit être maîtrisée (sur l'autoroute, je n'ai pas l'option *"roue dégonflée", mettez-vous sur le bas-côté, ça va quand même bien se passer")

Re,

Pour le fun , une méthode sans dictionary uniquement avec des fonctions Excel. Le code est plus court. C'est basé sur la fonction "Consolidation" (celle qu'on trouve dans le menu 'Données').

• Le code est dans module2. Il est un peu commenté.
• Cliquer sur le bouton de droite.

@MaFraise

Consolidate, cela existe depuis .... ?

Edit : since 2016.

Bonsoir BsAlv,

Maintenant Monsieur fait les questions ET les réponses.

Qu'est ce qu'il va nous rester...