Microsoft 365 Regroupement de quantité et longueur VBA ou Power Query

netparty · 28 Mai 2025

Bonjour à tous
Pourriez-vous m'aider pour mon fichier dans lequel j'aimerais avoir le rassemblement des données de l'onglet "Données" vers l'onglet "Recap", je ne sais pas ce qui est le mieux VBA ou Power Query pour faire cela.
Je vous explique en deux mots,
Dans l'onglet "Données" j'ai plusieurs tableaux T_DATA_1, T_DATA_2 qui reprennent des quantités et longueurs et j'aimerais regrouper tous cela dans un seul tableaux avec le détails de chaques tableaux et les totaux généraux.
Je joint mon fichier pour avoir un aperçu de ce que je souhaite avoir comme résultat dans l'onglet "Recap"
Merci d'avance pour votre aide.

chris · 28 Mai 2025

Bonjour à tous

Proposition PowerQuery utilisant tous les tableaux du classeur dont le nom commence par T_

djidji59430 · 28 Mai 2025

Bonjour à tous,

Avec un TCD

netparty · 28 Mai 2025

djidji59430 à dit:
Bonjour à tous,

Avec un TCD

Bonjour @djidji59430

Merci pour ton TCD, par contre si j'ajoute un tableau T_Data_3 supplémentaire sera t-il pris en compte ?

Bonne journée

Phil69970 · 28 Mai 2025

Bonjour à tous

Je te propose ce fichier
A noter j'ai modifié les valeurs pour les tests .... 😉

Merci de ton retour

netparty · 28 Mai 2025

Phil69970 à dit:
Bonjour à tous

Je te propose ce fichier
A noter j'ai modifié les valeurs pour les tests .... 😉

Merci de ton retour

Bonjour @Phil69970

Merci pour ton fichier.
Mais les données des tableaux T_Data_ ne seront pas fixe car je compte importer d'autre valeur donc la liste sera plus longue que le modèle.
J'aurais préférer sans formule pour ne pas devoir étendre les formules.

Dans le modèle il n'y a que 2 tableaux mais suivant le cas d'utilisation il y aura peut-être plusieurs tableaux.

Bonne journée

merinos-BernardEtang · 28 Mai 2025

Bonjour ,

PQ répond a cela facilement: je lui fais ouvrir un fichier, y rechercher les tables .
Puis j'applique une fonction aux tables... seules celles qui ont la bonne structure restent.

et enfin j'assemble les données

netparty · 28 Mai 2025

merinos-BernardEtang à dit:
Bonjour ,

PQ répond a cela facilement: je lui fais ouvrir un fichier, y rechercher les tables .
Puis j'applique une fonction aux tables... seules celles qui ont la bonne structure restent.

et enfin j'assemble les données

Merci
Mais j'aimerais tout avoir dans un seul classeur sans lien vers un fichier

chris · 28 Mai 2025

Bonjour à tous

Proposition PowerQuery utilisant tous les tableaux du classeur dont le nom commence par T_

netparty · 29 Mai 2025

chris à dit:
Bonjour à tous

Proposition PowerQuery utilisant tous les tableaux du classeur dont le nom commence par T_

Bonjour @chris

C'est exactement ce que j'avais besoin.

Merci de ton aide

cathodique · 29 Mai 2025

netparty à dit:
Bonjour @chris

C'est exactement ce que j'avais besoin.

Merci de ton aide

Bonjour tout le monde,

Je l'avais fait en vba sur la même idée de @chris 😉. C'est à dire parcourir tous les tableaux structurés dont le nom commence par "T_".
Si ça t’intéresses code ci-dessous à tester.

VB:

Option Explicit


Sub CreerTableauRecap()
   Dim ws As Worksheet, Tbs As ListObject, TbRecap As ListObject
   Dim cell As Range, dict As Object, Debut As Range
   Dim Cle As Variant, ligne As Integer

   Set dict = CreateObject("Scripting.Dictionary")

   ' Définir la feuille "Recap"
   Set ws = ThisWorkbook.Sheets("Recap")
   ws.Activate
   ' Vérifier si le tableau "T_Recap" existe, puis le supprimer
   On Error Resume Next
   Set TbRecap = ws.ListObjects("T_Recap")
   If Not TbRecap Is Nothing Then
      TbRecap.Delete
   End If
   On Error GoTo 0

   ' Parcourir toutes les feuilles et traiter les tableaux nommés "T_"
   Dim sht As Worksheet
   For Each sht In ThisWorkbook.Sheets
      For Each Tbs In sht.ListObjects
         If Left(Tbs.Name, 2) = "T_" And Tbs.Name <> "T_Recap" Then
            ' Parcourir les lignes du tableau
            For Each cell In Tbs.DataBodyRange.Columns(1).Cells
               Dim materiel As String, quantite As Variant, longueur As Variant
               materiel = cell.Value
               quantite = Null
               longueur = Null

               ' Vérifier les valeurs des colonnes Quantité et Longueur
               If Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 2).Value <> "" Then
                  quantite = Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 2).Value
               End If

               If Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 3).Value <> "" Then
                  longueur = Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 3).Value
               End If

               ' Ajouter ou cumuler les valeurs dans le dictionnaire
               If dict.exists(materiel) Then
                  If Not IsNull(quantite) Then dict(materiel)(0) = dict(materiel)(0) + quantite
                  If Not IsNull(longueur) Then dict(materiel)(1) = dict(materiel)(1) + longueur
               Else
                  dict.Add materiel, Array(quantite, longueur)
               End If
            Next cell
         End If
      Next Tbs
   Next sht

   ' Définir la cellule de départ pour le tableau récapitulatif (C3)
   Set Debut = ws.Range("C3")

   ' Créer un nouveau tableau structuré "T_Recap" à partir de C3
   Set TbRecap = ws.ListObjects.Add(xlSrcRange, Debut, , xlYes)
   TbRecap.Name = "T_Recap"
   TbRecap.HeaderRowRange.Cells(1, 1).Value = "Matériel"
   TbRecap.HeaderRowRange.Cells(1, 2).Value = "Quantité"
   TbRecap.HeaderRowRange.Cells(1, 3).Value = "Longueur"

   ' Insérer les données récapitulatives sans afficher de zéro
   ligne = Debut.Row + 1
   For Each Cle In dict.Keys
      ws.Cells(ligne, Debut.Column).Value = Cle
      If Not IsNull(dict(Cle)(0)) Then ws.Cells(ligne, Debut.Column + 1).Value = dict(Cle)(0)
      If Not IsNull(dict(Cle)(1)) Then ws.Cells(ligne, Debut.Column + 2).Value = dict(Cle)(1)
      ligne = ligne + 1
   Next Cle

   ' Adapter la plage du tableau à la nouvelle taille
   TbRecap.Resize ws.Range(Debut, ws.Cells(ligne - 1, Debut.Column + 2))

   ' Ajuster automatiquement la largeur des colonnes au contenu
   ws.Columns(Debut.Column).AutoFit
   ws.Columns(Debut.Column + 1).AutoFit
   ws.Columns(Debut.Column + 2).AutoFit

   'libère la mémoire
   Set ws = Nothing
   Set dict = Nothing
   Set TbRecap = Nothing
   Set ws = Nothing
   Set Tbs = Nothing
   Set cell = Nothing
   Set Debut = Nothing
End Sub

Bonne journée.

netparty · 29 Mai 2025

cathodique à dit:

Bonjour tout le monde,

Je l'avais fait en vba sur la même idée de @chris 😉. C'est à dire parcourir tous les tableaux structurés dont le nom commence par "T_".
Si ça t’intéresses code ci-dessous à tester.

VB:

Option Explicit


Sub CreerTableauRecap()
   Dim ws As Worksheet, Tbs As ListObject, TbRecap As ListObject
   Dim cell As Range, dict As Object, Debut As Range
   Dim Cle As Variant, ligne As Integer

   Set dict = CreateObject("Scripting.Dictionary")

   ' Définir la feuille "Recap"
   Set ws = ThisWorkbook.Sheets("Recap")
   ws.Activate
   ' Vérifier si le tableau "T_Recap" existe, puis le supprimer
   On Error Resume Next
   Set TbRecap = ws.ListObjects("T_Recap")
   If Not TbRecap Is Nothing Then
      TbRecap.Delete
   End If
   On Error GoTo 0

   ' Parcourir toutes les feuilles et traiter les tableaux nommés "T_"
   Dim sht As Worksheet
   For Each sht In ThisWorkbook.Sheets
      For Each Tbs In sht.ListObjects
         If Left(Tbs.Name, 2) = "T_" And Tbs.Name <> "T_Recap" Then
            ' Parcourir les lignes du tableau
            For Each cell In Tbs.DataBodyRange.Columns(1).Cells
               Dim materiel As String, quantite As Variant, longueur As Variant
               materiel = cell.Value
               quantite = Null
               longueur = Null

               ' Vérifier les valeurs des colonnes Quantité et Longueur
               If Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 2).Value <> "" Then
                  quantite = Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 2).Value
               End If

               If Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 3).Value <> "" Then
                  longueur = Tbs.DataBodyRange.Cells(cell.Row - Tbs.DataBodyRange.Row + 1, 3).Value
               End If

               ' Ajouter ou cumuler les valeurs dans le dictionnaire
               If dict.exists(materiel) Then
                  If Not IsNull(quantite) Then dict(materiel)(0) = dict(materiel)(0) + quantite
                  If Not IsNull(longueur) Then dict(materiel)(1) = dict(materiel)(1) + longueur
               Else
                  dict.Add materiel, Array(quantite, longueur)
               End If
            Next cell
         End If
      Next Tbs
   Next sht

   ' Définir la cellule de départ pour le tableau récapitulatif (C3)
   Set Debut = ws.Range("C3")

   ' Créer un nouveau tableau structuré "T_Recap" à partir de C3
   Set TbRecap = ws.ListObjects.Add(xlSrcRange, Debut, , xlYes)
   TbRecap.Name = "T_Recap"
   TbRecap.HeaderRowRange.Cells(1, 1).Value = "Matériel"
   TbRecap.HeaderRowRange.Cells(1, 2).Value = "Quantité"
   TbRecap.HeaderRowRange.Cells(1, 3).Value = "Longueur"

   ' Insérer les données récapitulatives sans afficher de zéro
   ligne = Debut.Row + 1
   For Each Cle In dict.Cles
      ws.Cells(ligne, Debut.Column).Value = Cle
      If Not IsNull(dict(Cle)(0)) Then ws.Cells(ligne, Debut.Column + 1).Value = dict(Cle)(0)
      If Not IsNull(dict(Cle)(1)) Then ws.Cells(ligne, Debut.Column + 2).Value = dict(Cle)(1)
      ligne = ligne + 1
   Next Cle

   ' Adapter la plage du tableau à la nouvelle taille
   TbRecap.Resize ws.Range(Debut, ws.Cells(ligne - 1, Debut.Column + 2))

   ' Ajuster automatiquement la largeur des colonnes au contenu
   ws.Columns(Debut.Column).AutoFit
   ws.Columns(Debut.Column + 1).AutoFit
   ws.Columns(Debut.Column + 2).AutoFit

   'libère la mémoire
   Set ws = Nothing
   Set dict = Nothing
   Set TbRecap = Nothing
   Set ws = Nothing
   Set Tbs = Nothing
   Set cell = Nothing
   Set Debut = Nothing
End Sub

Bonne journée.

Bonjour @cathodique

Merci pour le code

J'ai testé mais il y a une erreur à l’exécution de la macro

For Each Cle In dict.Cles

Bonne journée

cathodique · 29 Mai 2025

netparty à dit:
Bonjour @cathodique

Merci pour le code

J'ai testé mais il y a une erreur à l’exécution de la macro

Regarde la pièce jointe 1218565
For Each Cle In dict.Cles

Bonne journée

Oups!! grosses bêtises de débutant.😱😱😱
C'est plutôt

VB:

For Each Cle In dict.Keys

job75 · 29 Mai 2025

Bonjour à tous,

Voyez le fichier joint et le code de la feuille "Recap" :

VB:

Private Sub Worksheet_Activate()
Dim d As Object, LO As ListObject, n%, tablo, i&, resu(), nn&, a, j%, c As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each LO In Sheets("Données").ListObjects
    If LO.Range(1) = "Matériel" And LO.Range(1, 2) = "Quantité" And LO.Range(1, 3) = "Longueur" Then
        n = n + 1
        tablo = LO.Range 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            If Not d.exists(tablo(i, 1)) Then d(tablo(i, 1)) = d.Count 'mémorise la ligne
        Next i
    End If
Next LO
If n = 0 Then Cells.Delete: Exit Sub
ReDim resu(1 To d.Count + 2, 1 To 2 * n + 4)
n = 0
For Each LO In Sheets("Données").ListObjects
    If LO.Range(1) = "Matériel" And LO.Range(1, 2) = "Quantité" And LO.Range(1, 3) = "Longueur" Then
        n = n + 1
        resu(1, 2 * n) = LO.Name
        resu(2, 2 * n) = "Quantité"
        resu(2, 2 * n + 1) = "Longueur"
        tablo = LO.Range 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            nn = d(tablo(i, 1)) + 3 'récupère la ligne
            If IsNumeric(CStr(tablo(i, 2))) Then resu(nn, 2 * n) = resu(nn, 2 * n) + CDbl(tablo(i, 2))
            If IsNumeric(CStr(tablo(i, 3))) Then resu(nn, 2 * n + 1) = resu(nn, 2 * n + 1) + CDbl(tablo(i, 3))
        Next i
    End If
Next LO
'---total---
resu(1, 2 * n + 3) = "Total général"
resu(2, 2 * n + 2) = "  " 'pour la largeur de la colonne
resu(2, 2 * n + 3) = "Quantité"
resu(2, 2 * n + 4) = "Longueur"
a = d.keys
For i = 3 To UBound(resu)
    resu(i, 1) = a(i - 3)
    For j = 1 To n
        If IsNumeric(CStr(resu(i, 2 * j))) Then resu(i, 2 * n + 3) = resu(i, 2 * n + 3) + CDbl(resu(i, 2 * j))
        If IsNumeric(CStr(resu(i, 2 * j + 1))) Then resu(i, 2 * n + 4) = resu(i, 2 * n + 4) + CDbl(resu(i, 2 * j + 1))
Next j, i
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
With [C2] '1ère cellule de destination
    .Resize(UBound(resu), UBound(resu, 2)) = resu
    .Cells(3).Resize(UBound(resu) - 2).Borders.Weight = xlThin
    For Each c In .EntireRow.SpecialCells(xlCellTypeConstants)
        c.Resize(, 2).Merge 'fusionne
        c.Resize(UBound(resu), 2).Borders.Weight = xlThin
    Next c
    .Cells(1, 2).Resize(, UBound(resu, 2) - 1).EntireColumn.HorizontalAlignment = xlCenter
End With
Columns.AutoFit 'ajuste les largeurs
End Sub

La macro se déclenche quand on active la feuille.

Seuls sont traités les tableaux dont les titres des 3 1ères colonnes sont reconnus.

A+

netparty · 29 Mai 2025

job75 à dit:

Bonjour à tous,

Voyez le fichier joint et le code de la feuille "Recap" :

VB:

Private Sub Worksheet_Activate()
Dim d As Object, LO As ListObject, tablo, i&, resu(), n&, nn&, a, j%, c As Range
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each LO In Sheets("Données").ListObjects
    If LO.Range(1) = "Matériel" And LO.Range(1, 2) = "Quantité" And LO.Range(1, 3) = "Longueur" Then
        tablo = LO.Range 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            If Not d.exists(tablo(i, 1)) Then d(tablo(i, 1)) = d.Count 'mémorise la ligne
        Next i
    End If
Next LO
If d.Count = 0 Then Cells.Delete: Exit Sub
ReDim resu(1 To d.Count + 2, 1 To 2 * d.Count + 5)
For Each LO In Sheets("Données").ListObjects
    If LO.Range(1) = "Matériel" And LO.Range(1, 2) = "Quantité" And LO.Range(1, 3) = "Longueur" Then
        n = n + 1
        resu(1, 2 * n) = LO.Name
        resu(2, 2 * n) = "Quantité"
        resu(2, 2 * n + 1) = "Longueur"
        tablo = LO.Range 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            nn = d(tablo(i, 1)) + 3 'récupère la ligne
            resu(nn, 2 * n) = tablo(i, 2)
            resu(nn, 2 * n + 1) = tablo(i, 3)
        Next i
    End If
Next LO
'---total---
resu(1, 2 * n + 3) = "Total général"
resu(2, 2 * n + 2) = "  " 'pour la dimension de la colonne
resu(2, 2 * n + 3) = "Quantité"
resu(2, 2 * n + 4) = "Longueur"
a = d.keys
For i = 3 To UBound(resu)
    resu(i, 1) = a(i - 3)
    For j = 1 To n
        If IsNumeric(CStr(resu(i, 2 * j))) Then resu(i, 2 * n + 3) = resu(i, 2 * n + 3) + CDbl(resu(i, 2 * j))
        If IsNumeric(CStr(resu(i, 2 * j + 1))) Then resu(i, 2 * n + 4) = resu(i, 2 * n + 4) + CDbl(resu(i, 2 * j + 1))
Next j, i
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
With [C2] '1ère cellule de destination
    .Resize(UBound(resu), UBound(resu, 2)) = resu
    .Cells(3).Resize(UBound(resu) - 2).Borders.Weight = xlThin
    For Each c In .EntireRow.SpecialCells(xlCellTypeConstants)
        c.Resize(, 2).Merge 'fusionne
        c.Resize(UBound(resu), 2).Borders.Weight = xlThin
    Next c
    Columns.AutoFit 'ajuste les largeurs
End With
End Sub

La macro se déclenche quand on active la feuille.

Seuls sont traités les tableaux dont les titres des 3 1ères colonnes sont reconnus.

A+

Merci @job75

netparty · 29 Mai 2025

cathodique à dit:
Oups!! grosses bêtises de débutant.😱😱😱
C'est plutôt

VB:

For Each Cle In dict.Keys

@cathodique merci

Microsoft 365 Regroupement de quantité et longueur VBA ou Power Query

netparty

XLDnaute Occasionnel

Pièces jointes

chris

djidji59430

XLDnaute Barbatruc

Pièces jointes

netparty

XLDnaute Occasionnel

Phil69970

XLDnaute Barbatruc

Pièces jointes

netparty

XLDnaute Occasionnel

merinos-BernardEtang

XLDnaute Accro

Pièces jointes

netparty

XLDnaute Occasionnel

chris

XLDnaute Barbatruc

Pièces jointes

netparty

XLDnaute Occasionnel

cathodique

XLDnaute Barbatruc

netparty

XLDnaute Occasionnel

cathodique

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

netparty

XLDnaute Occasionnel

netparty

XLDnaute Occasionnel

Discussions similaires

Microsoft 365 Regroupement de quantité et longueur VBA ou Power Query

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Accro

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency