Microsoft 365 Regroupement de données identiques

netparty

XLDnaute Occasionnel
Bonjour à tous

Je sollicite votre aide pour une macro en vba.
J'ai dans la feuille IMPORT une série de données que je voudrai regrouper dans la feuille REGROUPEMENT.
J'aimerais que toutes les données soient regroupée par client, une ligne = un client et que les valeurs qui y sont associées soient comptabilisée.

Merci d'avance de votre aide.

Bonne journée à tous
 

Pièces jointes

  • Forum.xlsm
    9.8 KB · Affichages: 14
Solution
Bonsoir à tous,

@cp4 j'avais fait un code du genre y a un moment ;)👍
@netparty Voilà le code en question il est adaptable facilement (Ce code marche sur Mac et PC) :

Le code de base :
Code:
Sub AddOrConcatRemoveDupli() ' Créé par RyuAutodidacte
Dim Sep$, Crit, Col, y As Byte, cLig As New Collection, C As Byte, L&, R&, VA, VR, x

    Sep = "|" ' Le séparateur
    Crit = Array(1) ' Indiquer la ou les colonnes de critères
    '-------------------------
    Col = Array(2, 3, 4) 'Indiquer les colonnes concernées par les sommes ou les concaténations
    Oper = Array("", "", "") 'Pour chaque colonne de Col concernée, mettre "" pour additionner ou mettre caractère de concaténation (ex. : "|" ou bien vbNewLine, etc…)...

cp4

XLDnaute Barbatruc
Bonjour @cp4
Il y a juste la colonne tarif qui ne doit pas etre additionnée car sinon pour le reste c'est bon
Re, code à tester (on considère la concaténation colonne1 et colonne4 comme clé unique)
VB:
Option Explicit
Sub TotalClientTarif()
   Dim d As Object, Tbe, Tbs, clé, i As Long, lig As Integer, c As Integer
   Dim F1 As Worksheet, F2 As Worksheet
   Set d = CreateObject("Scripting.Dictionary")
   Set F1 = Sheets("import")
   Set F2 = Sheets("REGROUPEMENT")
   Application.ScreenUpdating = False

   Tbe = F1.Range("A2:D" & F1.[a65000].End(xlUp).Row)                   ' Tableau entrée
   ReDim Tbs(1 To UBound(Tbe), 1 To UBound(Tbe, 2))   ' Tableau sortie
   For i = LBound(Tbe) To UBound(Tbe)
      clé = Tbe(i, 1) & "|" & Tbe(i, 4)   'combinaison sans doublons

      If d.exists(clé) Then
         lig = d(clé)                 ' Récupération index du tableau Tbs()
      Else
         d(clé) = d.Count + 1
         lig = d.Count
         Tbs(lig, 1) = Tbe(i, 1)
         Tbs(lig, 4) = Tbe(i, 4)  ' Nouvelle clé
      End If
      For c = 2 To UBound(Tbe, 2) - 1
         Tbs(lig, c) = Tbs(lig, c) + Tbe(i, c)   ' Totalisation colonnes 2 et 3
      Next c
   Next i
   'restitution sur la feuille
   F2.[a1].CurrentRegion.Clear
   F1.[a1].Resize(, UBound(Tbe, 2)).Copy F2.[a1]
   F2.[A2].Resize(d.Count, UBound(Tbs, 2)) = Tbs

   Application.ScreenUpdating = False
   Set d = Nothing
   Set F1 = Nothing
   Set F2 = Nothing
End Sub
Résultat obtenu sur la feuille regroupement ci-dessous
1684861404923.png
 

netparty

XLDnaute Occasionnel
Re, code à tester (on considère la concaténation colonne1 et colonne4 comme clé unique)
VB:
Option Explicit
Sub TotalClientTarif()
   Dim d As Object, Tbe, Tbs, clé, i As Long, lig As Integer, c As Integer
   Dim F1 As Worksheet, F2 As Worksheet
   Set d = CreateObject("Scripting.Dictionary")
   Set F1 = Sheets("import")
   Set F2 = Sheets("REGROUPEMENT")
   Application.ScreenUpdating = False

   Tbe = F1.Range("A2:D" & F1.[a65000].End(xlUp).Row)                   ' Tableau entrée
   ReDim Tbs(1 To UBound(Tbe), 1 To UBound(Tbe, 2))   ' Tableau sortie
   For i = LBound(Tbe) To UBound(Tbe)
      clé = Tbe(i, 1) & "|" & Tbe(i, 4)   'combinaison sans doublons

      If d.exists(clé) Then
         lig = d(clé)                 ' Récupération index du tableau Tbs()
      Else
         d(clé) = d.Count + 1
         lig = d.Count
         Tbs(lig, 1) = Tbe(i, 1)
         Tbs(lig, 4) = Tbe(i, 4)  ' Nouvelle clé
      End If
      For c = 2 To UBound(Tbe, 2) - 1
         Tbs(lig, c) = Tbs(lig, c) + Tbe(i, c)   ' Totalisation colonnes 2 et 3
      Next c
   Next i
   'restitution sur la feuille
   F2.[a1].CurrentRegion.Clear
   F1.[a1].Resize(, UBound(Tbe, 2)).Copy F2.[a1]
   F2.[A2].Resize(d.Count, UBound(Tbs, 2)) = Tbs

   Application.ScreenUpdating = False
   Set d = Nothing
   Set F1 = Nothing
   Set F2 = Nothing
End Sub
Résultat obtenu sur la feuille regroupement ci-dessous
Regarde la pièce jointe 1170777
@cp4 super ton code, j'ai encore une question pour mieux comprendre, dans la feuille IMPORT j'ai ajouter une colonne NB Borne et cette valeur est unique par client et je voudrai aussi avoir cette valeur a coté de la ligne correspondant au client est-ce faisable.

Encore merci et bonne soirée
 

cp4

XLDnaute Barbatruc
Re,
cp4, dans le #5
net, de rien, c'était un plaisir pour moi...
Bonne soirée
VB:
Option Explicit

Sub TotalClientTarif()
   Dim d As Object, Tbe, Tbs, clé, i As Long, lig As Integer, c As Integer
   Dim F1 As Worksheet, F2 As Worksheet
   Set d = CreateObject("Scripting.Dictionary")
   Set F1 = Sheets("import")
   Set F2 = Sheets("REGROUPEMENT")
   Application.ScreenUpdating = False

   Tbe = F1.Range("tableau1")   'F1.Range("A2:D" & F1.[a65000].End(xlUp).Row)                   ' Tableau entrée
   ReDim Tbs(1 To UBound(Tbe), 1 To UBound(Tbe, 2))   ' Tableau sortie
   For i = LBound(Tbe) To UBound(Tbe)
      clé = Tbe(i, 1) & "|" & Tbe(i, 4) & "|" & Tbe(i, 5)  'combinaison sans doublons

      If d.exists(clé) Then
         lig = d(clé)                 ' Récupération index du tableau Tbs()
      Else
         d(clé) = d.Count + 1
         lig = d.Count
         Tbs(lig, 1) = Tbe(i, 1)
         Tbs(lig, 4) = Tbe(i, 4)  ' Nouvelle clé
         Tbs(lig, 5) = Tbe(i, 5) ' Nouvelle clé
      End If
      For c = 2 To UBound(Tbe, 2) - 2 '-2 pour ne pas totaliser les 2 dernières colonnes utilisées comme clés sans doublons.
         Tbs(lig, c) = Tbs(lig, c) + Tbe(i, c)   ' Totalisation colonnes 2 et 3
      Next c
   Next i
   'restitution sur la feuille
   F2.[a1].CurrentRegion.Clear
   F1.[a1].Resize(, UBound(Tbe, 2)).Copy F2.[a1]
   F2.[A2].Resize(d.Count, UBound(Tbs, 2)) = Tbs

   Application.ScreenUpdating = False
   Set d = Nothing
   Set F1 = Nothing
   Set F2 = Nothing
End Sub
Merci de pointer la solution (flèche haut/bas à droite du post) pour faciliter les recherches aux autres membres.
Bonne soirée.
 

Cousinhub

XLDnaute Barbatruc
Re-,
Juste pour le fun...
Le code M (Power Query) :
PowerQuery:
let
    Source = Excel.CurrentWorkbook(){[Name="Tableau1"]}[Content], // Chargement du tableau de données
    GroupBy = Table.Group(Source, {"Client", "Tarif", "NB Bornes"}, {{"Kwh", each List.Sum([Kwh]), type number}, {"Prix", each List.Sum([Prix par consommation]), type number}}), // Le calcul en 1 ligne
    Rangement = Table.ReorderColumns(GroupBy,{"Client", "Kwh", "Prix", "Tarif", "NB Bornes"}) // pour faire joli
in
    Rangement // Pour finir

Bonne soirée
 

cp4

XLDnaute Barbatruc
Re,
cp4, dans le #5
net, de rien, c'était un plaisir pour moi...
Bonne soirée
Bonsoir,

@Cousinhub : Je travaille avec Excel2010 32 bits sur Windows7 6 bits. Je t'avoue que j'ai eu tellement de problème sur mon pc que je n'ai pas eu le courage d'ajouter l'addon, pour utiliser PowerQuery.
Sinon, j'ai découvert sur le forum que c'est un outil puissant.
Bonne soirée.
 

Cousinhub

XLDnaute Barbatruc
Bonsoir,

@Cousinhub : Je travaille avec Excel2010 32 bits sur Windows7 6 bits. Je t'avoue que j'ai eu tellement de problème sur mon pc que je n'ai pas eu le courage d'ajouter l'addon, pour utiliser PowerQuery.
Sinon, j'ai découvert sur le forum que c'est un outil puissant.
Bonne soirée.
Hi,
C'est dommage, mais tu devrais vraiment essayer...
C'est gratuit, et comme tu le dis, très puissant
Passe une bonne soirée
 

Cousinhub

XLDnaute Barbatruc
Bonsoir netparty,
Si je dérange dans ton fil, tu es entièrement en droit de me le dire...
Si ma solution (tout comme celle de lolote83) issue de Power Query ne te convient pas, tu as également le droit de le dire...
Après tout, ce sera ton choix (cependant, comme le dit ma signature....)
Bonne continuation
 

netparty

XLDnaute Occasionnel
Bonsoir netparty,
Si je dérange dans ton fil, tu es entièrement en droit de me le dire...
Si ma solution (tout comme celle de lolote83) issue de Power Query ne te convient pas, tu as également le droit de le dire...
Après tout, ce sera ton choix (cependant, comme le dit ma signature....)
Bonne continuation
Bonjour @Cousinhub
Non tu ne me dérange pas du tout j ai juste du mail avec le power Query je n'arrive pas à comprendre la logique du power query le vba me semble plus clair.
Bonne soirée
 

RyuAutodidacte

XLDnaute Impliqué
Supporter XLD
Bonsoir à tous,

@cp4 j'avais fait un code du genre y a un moment ;)👍
@netparty Voilà le code en question il est adaptable facilement (Ce code marche sur Mac et PC) :

Le code de base :
Code:
Sub AddOrConcatRemoveDupli() ' Créé par RyuAutodidacte
Dim Sep$, Crit, Col, y As Byte, cLig As New Collection, C As Byte, L&, R&, VA, VR, x

    Sep = "|" ' Le séparateur
    Crit = Array(1) ' Indiquer la ou les colonnes de critères
    '-------------------------
    Col = Array(2, 3, 4) 'Indiquer les colonnes concernées par les sommes ou les concaténations
    Oper = Array("", "", "") 'Pour chaque colonne de Col concernée, mettre "" pour additionner ou mettre caractère de concaténation (ex. : "|" ou bien vbNewLine, etc…)
    '-------------------------
 
    With ActiveSheet
        VA = .Cells(1).CurrentRegion.Value
        ReDim VR(1 To UBound(VA), 1 To UBound(VA, 2))
        ReDim x(1 To UBound(VA))
        For R = 1 To UBound(VA)
     
            For i = LBound(Crit) To UBound(Crit):  S = IIf(i = 0, VA(R, Crit(i)), S & Sep & VA(R, Crit(i))): Next
            x(R) = S
         
            On Error Resume Next
                L = cLig(x(R))
            On Error GoTo 0
         
            If L Then
                For y = LBound(Col) To UBound(Col)
                    If Oper(y) = "" Then
                        VR(L, Col(y)) = VR(L, Col(y)) + VA(R, Col(y))
                    Else
                        VR(L, Col(y)) = VR(L, Col(y)) & Oper(y) & VA(R, Col(y))
                    End If
                Next
            Else
                L = cLig.Count + 1
                cLig.Add L, CStr(x(R))
                For C = 1 To UBound(VA, 2):  VR(L, C) = VA(R, C):  Next
            End If
            L = 0
        Next
        If cLig.Count < UBound(VR) Then
            Application.ScreenUpdating = False
            .Range(Cells(1, 1), Cells(1, UBound(VA, 2))).Resize(cLig.Count).Value = VR
            .Rows(cLig.Count + 1 & ":" & UBound(VA)).Delete
            Application.ScreenUpdating = True
        End If
    End With
Set cLig = Nothing
End Sub

Le code adapté à ton 1er fichier :
Code:
Sub AddOrConcatRemoveDupli() ' Créé par RyuAutodidacte
Dim Sep$, Crit, Col, y As Byte, cLig As New Collection, C As Byte, L&, R&, VA, VR, x, DerL&

    Sep = "|" ' Le séparateur
    Crit = Array(1) ' Indiquer la ou les colonnes de critères
    '-------------------------
    Col = Array(2, 3, 4) 'Indiquer les colonnes concernées par les sommes ou les concaténations
    Oper = Array("", "", "") 'Pour chaque colonne de Col concernée, mettre "" pour additionner ou mettre caractère de concaténation (ex. : "|" ou bien vbNewLine, etc…)
    '-------------------------
 
        VA = Sheets("IMPORT").Cells(1).CurrentRegion.Offset(1).Value
        ReDim VR(1 To UBound(VA), 1 To UBound(VA, 2))
        ReDim x(1 To UBound(VA))
        For R = 1 To UBound(VA)
     
            For i = LBound(Crit) To UBound(Crit):  S = IIf(i = 0, VA(R, Crit(i)), S & Sep & VA(R, Crit(i))): Next
            x(R) = S
         
            On Error Resume Next
                L = cLig(x(R))
            On Error GoTo 0
         
            If L Then
                For y = LBound(Col) To UBound(Col)
                    If Oper(y) = "" Then
                        VR(L, Col(y)) = VR(L, Col(y)) + VA(R, Col(y))
                    Else
                        VR(L, Col(y)) = VR(L, Col(y)) & Oper(y) & VA(R, Col(y))
                    End If
                Next
            Else
                L = cLig.Count + 1
                cLig.Add L, CStr(x(R))
                For C = 1 To UBound(VA, 2):  VR(L, C) = VA(R, C):  Next
            End If
            L = 0
        Next
     
        If cLig.Count < UBound(VR) Then
            Application.ScreenUpdating = False
            With Sheets("REGROUPEMENT")
                DerL = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                .Range(.Cells(DerL, 1), .Cells(DerL, UBound(VA, 2))).Resize(cLig.Count).Value = VR
            End With
            Sheets("IMPORT").Rows(2 & ":" & UBound(VA)).Delete
            Application.ScreenUpdating = True
        End If
Set cLig = Nothing
End Sub

Si tu l'essayes tu verras qu'il est adaptable sur le(s) critère(s) (colonne 1=> les clients), les colonnes concernées par la somme 2,3 et 4, et indiqué que l'on veut la somme pour chaque colonnes 2,3,4 => avec Oper = Array("", "", "")

NB : Je te laisse le soin de mettre les paramètre qui te conviennent ;)

Petit Update sur le code, j'avais oublié de mettre le :
Application.ScreenUpdating = True
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 713
Messages
2 081 806
Membres
101 819
dernier inscrit
lukumubarth