Microsoft 365 Regroupement de données identiques

netparty · 23 Mai 2023

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

cp4 · 23 Mai 2023

netparty à dit:
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

netparty · 23 Mai 2023

cp4 à dit:

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 · 23 Mai 2023

netparty à dit:
@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

Envoie un fichier avec la nouvelle colonne supplémentaire.

Cousinhub · 23 Mai 2023

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

cp4 · 23 Mai 2023

Cousinhub à dit:
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 · 23 Mai 2023

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 · 23 Mai 2023

Cousinhub à dit:
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 · 23 Mai 2023

cp4 à dit:
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

netparty · 23 Mai 2023

cp4 à dit:
Envoie un fichier avec la nouvelle colonne supplémentaire.

Ci-joint un fichier avec une colonne supplémentaire
Encore merci et bonne soirée

Cousinhub · 23 Mai 2023

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 · 23 Mai 2023

Cousinhub à dit:
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

Cousinhub · 23 Mai 2023

Re-,
Tu apportes la preuve, avec tes demandes de précisions, d'adaptation...
Tu ne maîtrises pas plus le VBA que PQ (OK, que tu ne connais pas encore, je le conçois)
Mais un peu de curiosité de ta part, et c'est gagné
Bonne soirée

Staple1600 · 23 Mai 2023

Bonjour le fil

@Cousinhub
[Pour infos]
Il trop tard, Monsieur Placard !

Prosélytisme éhonté pour upgrader son Office à dit:
Les versions d'Office suivantes sont prises en charge :

Microsoft Office 2010 Professional Plus avec Software Assurance

Microsoft Office 2013

[/pour infos]

cp4 · 23 Mai 2023

netparty à dit:
Ci-joint un fichier avec une colonne supplémentaire
Encore merci et bonne soirée

J'ai pris le fichier du post#5, le code est au post#20.
Tu devras adapter

VB:

Tbe = F1.Range("tableau1")  'ou' 'F1.Range("A2:E" & F1.[a65000].End(xlUp).Row)

RyuAutodidacte · 24 Mai 2023

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

Microsoft 365 Regroupement de données identiques

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Impliqué

Discussions similaires

Partager cette page

Statistiques des forums