cumuler une colonne en fonction de 2 critères

[FREDPLONGEUR]

Bonjour Forum

J'ai un tableau de 33 000 lignes

en colonne A j'ai un code société
en colonne B j'ai la raison sociale
en colonne C une référence produit
en colonne D une quantité
en colonne E un montant

je souhaite cumulé les quantité de la colonne D et les
montants de la colonne E si même référence produit pour le même code société
et ne garder que ces cumuls

mon tableau est bien trié par code société et référence

je joint un fichier pour exemple avec tableau départ et objectif de la macro

merci d'avance de votre aide

Fred

 

[Staple1600]

Re : cumuler une colonne en fonction de 2 critères

Bonjour à tous


Tu peux aussi utiliser un TCD ou Données/Sous-total en lieu et place d'une macro.

 

[FREDPLONGEUR]

Re : cumuler une colonne en fonction de 2 critères

merci Staple1600,

c'est j'ai tout un traitement par macro fait avant et je
fait le même sur plusieurs tableaux
dans la foulée je continue

de plus je manipule pas bien les tableaux croisés dynamique


merci à toi


Fred

 

[Staple1600]

Re : cumuler une colonne en fonction de 2 critères

Re

Oui, j'ai d'ailleurs posté une macro dans ton autre fil que tu sembles avoir zappé

Tu as tous les outils, tutoriels disponibles sur ce forum et sur le net pour savoir utiliser les TCD

Ei si tu vraiment , tu veux du VBA, tu peux utiliser l'enregistreur de macros tout en faisant Données/Sous-total.
Tu auras ainsi à ta disposition un code VBA de base.

 

[FREDPLONGEUR]

Re : cumuler une colonne en fonction de 2 critères

merci encore Staple1600

effectivement je n'avais pas vu ta macro de l'autre fil

merci à toi

j'utilise également l'enregistrement auto des macros
mais comme je ne sais pas cumuler deux colonnes celons 2 critères
même sans macro, j'ai du mal à m'en sortir

merci de ton aide
fred

 

[Staple1600]

Re : cumuler une colonne en fonction de 2 critères

Re,

Voici ce que peut donner un TCD

Tu es sur ne pas vouloir réviser ta position à ce sujet ?

 

[FREDPLONGEUR]

Re : cumuler une colonne en fonction de 2 critères

Merci beaucoup Staple1600

tu as eu raison d'insister sur le tableau dynamique
je me suis lancé et m'a donné des idées
je m'en débrouille pas si mal au final

merci beaucoup pour tes conseils

Bonnes Fêtes

Fred

 

[klin89]

Re : cumuler une colonne en fonction de 2 critères

Bonsoir le forum et bonne année à tous,

Vois ceci :

Sub Essai()
Dim a, i As Long, j As Long, w, n As Long, txt As String
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("A2").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    .Item(txt) = VBA.Array(.Count + 2, 5)
                    For j = 1 To 3
                        a(.Item(txt)(0), j) = a(i, j)
                    Next
                    a(.Item(txt)(0), 4) = a(i, 4)
                    a(.Item(txt)(0), 5) = a(i, 4) * a(i, 5)
                Else
                    w = .Item(txt)
                    a(w(0), 4) = a(w(0), 4) + a(i, 4)
                    a(w(0), 5) = a(w(0), 5) + (a(i, 4) * a(i, 5))
                End If
            Next
            n = .Count + 1
        End With
        'Résultat dans la même feuille
        With .Offset(, .Columns.Count + 1).Resize(n, UBound(a, 2))
            .CurrentRegion.Clear
            .Value = a
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 40
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
        End With
        'Résultat en Feuil2
'        With Sheets("Feuil2").Cells(1).Resize(n, UBound(a, 2))
'            .CurrentRegion.Clear
'            .Value = a
'            'Blablabla
'            .Columns.AutoFit
'            .Parent.Select
'        End With
    End With
    Application.ScreenUpdating = True
End Sub

Klin89

 

[klin89]

Re : cumuler une colonne en fonction de 2 critères

Re,

Cette version plus claire que la précédente.

Sub Version1()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    With Range("A2").CurrentRegion
        a = .Value: n = 1
        a(1, 1) = "Code client": a(1, 2) = "Raison sociale"
        a(1, 3) = "Référence": a(1, 5) = "Montant net HT"
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    n = n + 1
                    For j = 1 To 4
                        a(n, j) = a(i, j)
                    Next
                    a(n, 5) = a(i, 4) * a(i, 5)
                    .Item(txt) = n
                Else
                    a(.Item(txt), 4) = a(.Item(txt), 4) + a(i, 4)
                    a(.Item(txt), 5) = a(.Item(txt), 5) + (a(i, 4) * a(i, 5))
                End If
                txt = Empty
            Next
        End With
        'Résultat dans la même feuille
        With .Offset(, .Columns.Count + 1).Resize(n, UBound(a, 2))
            .CurrentRegion.Clear
            .Value = a
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 19
                .BorderAround Weight:=xlThin
            End With
            .Columns(5).NumberFormat = "#,##0.00 €"
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Pour le fun cette 2ème version, j'ai rajouté une colonne pour dénombrer les références, et comprendre le "mécanisme"

Sub Version2()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    With Range("A2").CurrentRegion
        a = .Value: n = 1
        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
        a(1, 1) = "Code client": a(1, 2) = "Raison sociale"
        a(1, 3) = "Référence": a(1, 4) = "Nombre réf"
        a(1, 5) = "Quantité": a(1, 6) = "Montant net HT"
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                txt = Join(Array(a(i, 1), a(i, 2), a(i, 3)), Chr(2))
                If Not .exists(txt) Then
                    n = n + 1
                    For j = 1 To 3
                        a(n, j) = a(i, j)
                    Next
                    a(n, 6) = a(i, 4) * a(i, 5)
                    a(n, 5) = a(i, 4)
                    a(n, 4) = 1
                    .Item(txt) = n
                Else
                    a(.Item(txt), 6) = a(.Item(txt), 6) + (a(i, 4) * a(i, 5))
                    a(.Item(txt), 5) = a(.Item(txt), 5) + a(i, 4)
                    a(.Item(txt), 4) = a(.Item(txt), 4) + 1
                End If
                txt = Empty
            Next
        End With
        'Résultat dans la même feuille
        With .Offset(, .Columns.Count + 1).Resize(n, UBound(a, 2))
            .CurrentRegion.Clear
            .Value = a
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 40
                .BorderAround Weight:=xlThin
            End With
            .Columns(6).NumberFormat = "#,##0.00 €"
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89