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

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion netparty
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
N

netparty

XLDnaute Occasionnel
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.
 

Pièces jointes

Trier par date Trier par votes
Phil69970 à dit:
Bonjour à tous

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

Merci de ton retour
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
netparty à dit:
Bonjour @chris

C'est exactement ce que j'avais besoin.

Merci de ton aide
Cliquez pour agrandir...
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.
 
Dernière édition:
Vote positif 0 Vote négatif
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.
Cliquez pour agrandir...
Bonjour @cathodique

Merci pour le code

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


1748508558007.png

For Each Cle In dict.Cles

Bonne journée
 
Vote positif 0 Vote négatif
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+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
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+
Cliquez pour agrandir...
Merci @job75
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

F
  • Résolu(e)
XL 2021 VBA et Power Query : ecrire des requetes avec variables
2
Réponses
28
Affichages
2 K
Florent74
F
M
  • Résolu(e)
Microsoft 365 Power Query - Regroupement date début/date de fin
Réponses
9
Affichages
968
Maxou69
M
M
  • Question Question
XL 2010 Récupération de données et les transformer avec Power Query ?
Réponses
3
Affichages
626
DJunqueira
D
vgendron
  • Question Question
Power Query Premiers Pas Power Query, combiner tableaux provenant de différents onglets
Réponses
8
Affichages
1 K
vgendron
vgendron
M
  • Question Question
XL 2016 Récupérer la planification d'un excel et la croiser avec un planning d'un autre Excel
Réponses
5
Affichages
966
vgendron
vgendron
Deadpool_CC
  • Question Question
XL 2016 Pilotage via VBA d'une connexion Power Query à Salesforce
Réponses
6
Affichages
1 K
Hasco
Hasco
T
  • Résolu(e)
Power Query Regroupement de table et addition
2
Réponses
15
Affichages
2 K
tuonoman
T
D
  • Question Question
Microsoft 365 Combiner requetes Power Query ou VBA
Réponses
6
Affichages
2 K
chris
chris
S
  • Question Question
XL 2010 VBA - macro avec 1 boucle qui alterne 1 action à conditions et 1 action sans conditions
2 3 4
Réponses
58
Affichages
7 K
Scorp0211
S
L
  • Question Question
XL 2013 [Analytique] Comment faire ceci avec Power Query... ou VBA ?
Réponses
12
Affichages
2 K
Leguyl
L
D
  • Question Question
VBA et regroupement de données
2
Réponses
26
Affichages
4 K
Dranreb
Dranreb
K
  • Question Question
Regroupement de colonnes automatisé par macro VBA
Réponses
0
Affichages
3 K
kokosei
K
M
[REF] Wiki 4 de MichelXld (Fonctions, Evenements, Dates et calendriers, Flash , Ooo)
Réponses
0
Affichages
35 K
MichelXld
M
Retour