Macro synthétique (Copier coller somme en fonction de plusieurs critères)

Le 23/12/2017 à 15:14

Bonjour à tous tout d'abord joyeuse fête de Noel à tous et une très bonne année à venir

Je viens vous solliciter votre appui pour un projet hyper important j'ai mis toutes les remarques en expliquant point par point directement sur le fichier excel joint.

Please aidez moi

21rapport-de-transaction.xlsx (34.62 Ko)
Le 23/12/2017 à 18:20

Bonjour

Je ne comprends pas bien la différence entre ta feuille Achat-Vente et ta feuille Synthèse. Je dois être stupide.

Les lignes que tu as remplies pour ton exemple ne semblent pas correspondre à ce que tu dmandes ???

Merci de m'éclairer un peu plus si tu veux que j'essaie de t'aider

A+

Le 23/12/2017 à 19:02

Bonjour

Bonjour à tous

Un essai à tester. Te convient-il ?

Patty5046 a écrit :

...Je dois être stupide...

Oh que non !

Les valeurs données en exemple ne sont pas bonnes alors, il faut s'arracher quelques cheveux pour comprendre...sans être sûr du résultat !

Bye !

25rapport-de-transaction-v1.xlsm (55.49 Ko)
Le 23/12/2017 à 19:14

Bonsoir gmb

Tu me rassures

Bonnes fêtes de fin d'année

Cordialement

Le 23/12/2017 à 21:35

Bonsoir à tous,

Pour remplir la feuille "Achat-Vente" :

Option Explicit
Sub test()
Dim dico As Object, i As Long, n As Long, w(), e, s
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    'la feuille source en 1ère position dans le classeur
    With Sheets(1).Range("a8").CurrentRegion
        For i = 2 To .Rows.Count
            If Not dico.exists(.Cells(i, 1).Interior.ColorIndex) Then
                Set dico(.Cells(i, 1).Interior.ColorIndex) = CreateObject("Scripting.Dictionary")
                dico(.Cells(i, 1).Interior.ColorIndex).CompareMode = 1
            End If
            If Not dico(.Cells(i, 1).Interior.ColorIndex).exists(.Cells(i, 1).Value) Then
                ReDim w(1 To 4, 1 To 1)
            Else
                w = dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value)
                ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
            End If
            w(1, UBound(w, 2)) = .Cells(i, 1).Value
            w(2, UBound(w, 2)) = .Cells(i, 5).Value
            w(3, UBound(w, 2)) = .Cells(i, 4).Value
            w(4, UBound(w, 2)) = .Cells(i, 4).Value * .Cells(i, 5).Value
            dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value) = w
        Next
    End With
    'restitution dans la feuille cible
    With Sheets("Achat-Vente")
        'achat ---> bleu = 23
        'vente ---> rouge = 46
        For Each e In Array(Array(23, "a3"), Array(46, "g3"))
            With .Range(e(1))
                .CurrentRegion.Offset(2).ClearContents
                For Each s In dico.Item(e(0))
                    With .Offset(n).Resize(UBound(dico.Item(e(0)).Item(s), 2), _
                                           UBound(dico.Item(e(0)).Item(s), 1))
                        .Value = Application.Transpose(dico.Item(e(0)).Item(s))
                    End With
                    n = n + UBound(dico.Item(e(0)).Item(s), 2)
                Next
            End With
            n = 0
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Bonne fêtes à tous

klin89

Le 24/12/2017 à 13:14
Patty5046 a écrit :

Bonjour

Je ne comprends pas bien la différence entre ta feuille Achat-Vente et ta feuille Synthèse. Je dois être stupide.

Les lignes que tu as remplies pour ton exemple ne semblent pas correspondre à ce que tu dmandes ???

Merci de m'éclairer un peu plus si tu veux que j'essaie de t'aider

A+

Effectivement les données ne sont pas juste j'ai mal calculer dsl

En fait la feuille Synthèse fera le total des quantités de mémé titre et et mémé cours, puisque sur la feuille Achat vente; il peut y avoir plusieurs lignes. Je m'explique d'avantage dans la capture d’écran.

capture 1
Le 24/12/2017 à 13:15
Klin89 a écrit :

Bonsoir à tous,

Pour remplir la feuille "Achat-Vente" :

Option Explicit
Sub test()
Dim dico As Object, i As Long, n As Long, w(), e, s
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    'la feuille source en 1ère position dans le classeur
    With Sheets(1).Range("a8").CurrentRegion
        For i = 2 To .Rows.Count
            If Not dico.exists(.Cells(i, 1).Interior.ColorIndex) Then
                Set dico(.Cells(i, 1).Interior.ColorIndex) = CreateObject("Scripting.Dictionary")
                dico(.Cells(i, 1).Interior.ColorIndex).CompareMode = 1
            End If
            If Not dico(.Cells(i, 1).Interior.ColorIndex).exists(.Cells(i, 1).Value) Then
                ReDim w(1 To 4, 1 To 1)
            Else
                w = dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value)
                ReDim Preserve w(1 To 4, 1 To UBound(w, 2) + 1)
            End If
            w(1, UBound(w, 2)) = .Cells(i, 1).Value
            w(2, UBound(w, 2)) = .Cells(i, 5).Value
            w(3, UBound(w, 2)) = .Cells(i, 4).Value
            w(4, UBound(w, 2)) = .Cells(i, 4).Value * .Cells(i, 5).Value
            dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value) = w
        Next
    End With
    'restitution dans la feuille cible
    With Sheets("Achat-Vente")
        'achat ---> bleu = 23
        'vente ---> rouge = 46
        For Each e In Array(Array(23, "a3"), Array(46, "g3"))
            With .Range(e(1))
                .CurrentRegion.Offset(2).ClearContents
                For Each s In dico.Item(e(0))
                    With .Offset(n).Resize(UBound(dico.Item(e(0)).Item(s), 2), _
                                           UBound(dico.Item(e(0)).Item(s), 1))
                        .Value = Application.Transpose(dico.Item(e(0)).Item(s))
                    End With
                    n = n + UBound(dico.Item(e(0)).Item(s), 2)
                Next
            End With
            n = 0
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Bonne fêtes à tous

klin89

Merci bien c'est super!

Le 24/12/2017 à 13:54
gmb a écrit :

Bonjour

Bonjour à tous

Un essai à tester. Te convient-il ?

Patty5046 a écrit :

...Je dois être stupide...

Oh que non !

Les valeurs données en exemple ne sont pas bonnes alors, il faut s'arracher quelques cheveux pour comprendre...sans être sûr du résultat !

Bye !

Effectivement les valeurs ne sont pas juste j'ai fais un mauvais calcul . Merci GMB pour ton fichier c'est parfait pour la feuille Achat vente maintenant c'est la feuille ''Synthèse'' qui ne prend pas.

Aussi j'ai tester en copiant les données d'un autre rapport et coller (à partir de la cellule A9 sur le fichier que tu m'envoyé; ça mets ''débogage". je mets un autre rapport pour test

capture 3
Le 24/12/2017 à 14:10

re bidexcel,

Pour remplir la feuille "Synthese" :

Option Explicit
Sub test2()
Dim dico As Object, i As Long, n As Long, w(), e, s, v
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    'la feuille source doit etre placee en 1ère position dans le classeur
    With Sheets(1).Range("a8").CurrentRegion
        For i = 2 To .Rows.Count
            If Not dico.exists(.Cells(i, 1).Interior.ColorIndex) Then
                Set dico(.Cells(i, 1).Interior.ColorIndex) = CreateObject("Scripting.Dictionary")
                dico(.Cells(i, 1).Interior.ColorIndex).CompareMode = 1
            End If
            If Not dico(.Cells(i, 1).Interior.ColorIndex).exists(.Cells(i, 1).Value) Then
                Set dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value) = CreateObject("Scripting.Dictionary")
            End If
            If Not dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value).exists(.Cells(i, 4).Value) Then
                ReDim w(1 To 4)
                w(1) = .Cells(i, 1).Value: w(3) = .Cells(i, 4).Value
            Else
                w = dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value)(.Cells(i, 4).Value)
            End If
            w(2) = w(2) + .Cells(i, 5).Value
            w(4) = w(2) * w(3)
            dico(.Cells(i, 1).Interior.ColorIndex)(.Cells(i, 1).Value)(.Cells(i, 4).Value) = w
        Next
    End With
    'restitution dans la feuille cible
    With Sheets("Synthese")
        'achat ---> bleu = 23
        'vente ---> rouge = 46
        For Each e In Array(Array(23, "a3"), Array(46, "g3"))
            With .Range(e(1))
                .CurrentRegion.Offset(2).ClearContents
                For Each s In dico(e(0))
                    For Each v In dico(e(0))(s)
                        With .Offset(n).Resize(1, UBound(dico(e(0))(s)(v), 1))
                            .Value = dico(e(0))(s)(v)
                        End With
                        n = n + 1
                    Next
                Next
            End With
            n = 0
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

La dernière boucle pourrait être retranscrite comme ceci, Item étant la propriété par défaut du dictionnaire

For Each e In Array(Array(23, "a3"), Array(46, "g3"))
    With .Range(e(1))
        .CurrentRegion.Offset(2).ClearContents
        For Each s In dico.Item(e(0))
            For Each v In dico.Item(e(0)).Item(s)
                With .Offset(n).Resize(1, UBound(dico.Item(e(0)).Item(s).Item(v), 1))
                    .Value = dico.Item(e(0)).Item(s).Item(v)
                End With
                n = n + 1
            Next
        Next
    End With
    n = 0
Next

klin89

Le 24/12/2017 à 14:34

Salut comprends pas trop j'ai coller ta formule mais le débogage est la encore si tu pouvais mettre un bouton de commande pour moi ca serait génial

Le 24/12/2017 à 17:10

A qui t'adresses tu bidexcel

Le code fonctionne dans le premier fichier joint, puisque je me base sur les 2 couleurs pour déterminer les clés du dictionnaire.

Dans le dernier code, on peut simplifier en supprimant une boucle imbriquée 

For Each e In Array(Array(23, "a3"), Array(46, "g3"))
    With .Range(e(1))
        .CurrentRegion.Offset(2).ClearContents
        For Each s In dico(e(0))
            .Offset(n).Resize(UBound(Application.Transpose(dico(e(0))(s).items), 2), _
                              UBound(Application.Transpose(dico(e(0))(s).items), 1)).Value = _
                              Application.Transpose(Application.Transpose(dico(e(0))(s).items))
            n = n + dico(e(0))(s).Count
        Next
    End With
    n = 0
Next

klin89

Le 26/12/2017 à 19:55

Coucou

Le 26/12/2017 à 20:49

Re bidexcel,

On peut déterminer les clés du dictionnaire parent sans tenir compte des 2 couleurs.

Le code réajusté :

Option Explicit
Sub test2()
Dim dico As Object, cle As String, i As Long, n As Long
Dim a, w(), e, s
    Set dico = CreateObject("Scripting.Dictionary")
    'la feuille source doit etre placee en 1ere position dans le classeur
    With Sheets(1).Range("a8").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not IsEmpty(a(i, 8)) Then
                If IsEmpty(a(i, 13)) Then
                    cle = "achat"
                Else
                    cle = "achatetvente"
                End If
            Else
                cle = "vente"
            End If
            If Not dico.exists(cle) Then
                Set dico(cle) = CreateObject("Scripting.Dictionary")
                dico(cle).CompareMode = 1
            End If
            If Not dico(cle).exists(a(i, 1)) Then
                Set dico(cle)(a(i, 1)) = CreateObject("Scripting.Dictionary")
            End If
            If Not dico(cle)(a(i, 1)).exists(a(i, 4)) Then
                ReDim w(1 To 4)
                w(1) = a(i, 1): w(3) = a(i, 4)
            Else
                w = dico(cle)(a(i, 1))(a(i, 4))
            End If
            w(2) = w(2) + a(i, 5)
            w(4) = w(2) * w(3)
            dico(cle)(a(i, 1))(a(i, 4)) = w
        Next
    End With
    Application.ScreenUpdating = False
    'restitution dans la feuille cible
    With Sheets("Synthese")
        For Each e In Array(Array("achat", "a3"), Array("vente", "g3"))
            With .Range(e(1))
                .CurrentRegion.Offset(2).ClearContents
                For Each s In dico(e(0))
                    .Offset(n).Resize(UBound(Application.Transpose(dico(e(0))(s).items), 2), _
                                      UBound(Application.Transpose(dico(e(0))(s).items), 1)).Value = _
                                      Application.Transpose(Application.Transpose(dico(e(0))(s).items))
                    n = n + dico(e(0))(s).Count
                Next
            End With
            n = 0
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Je te rappelle que les données de la feuille source commencent en A8 dans ton exemple

klin89

Le 27/12/2017 à 20:41

Salut Klin89 grand merci pour le fichier il fonctionne bien mais j'ai remarque qu il ne prenait pas en compte les transactions croisées de type "C'' (pour ces transactions il y a fois 'sur la ligne de la transaction ''203' dans la colonne des achats ainsi que des ventes

comme le montre le fichier que j'ai joint.

Si tu peux m'aider pour ce dernier détail ça serait super super cool

27macro.xlsm (49.15 Ko)
Le 27/12/2017 à 21:26

Re bidexcel

Faut te suivre

Il faut donc simplement boucler sur la colonne 8 et 13

Option Explicit
Sub test2()
Dim dico As Object, cle As String, i As Long, n As Long
Dim a, w(), e, s
    Set dico = CreateObject("Scripting.Dictionary")
    'la feuille source doit etre placee en 1ere position dans le classeur
    With Sheets(1).Range("a8").CurrentRegion
        a = .Value
        For Each e In Array(Array(8, "achat"), Array(13, "vente"))
            For i = 2 To UBound(a, 1)
                If Not IsEmpty(a(i, e(0))) Then
                    cle = e(1)
                    If Not dico.exists(cle) Then
                        Set dico(cle) = CreateObject("Scripting.Dictionary")
                        dico(cle).CompareMode = 1
                    End If
                    If Not dico(cle).exists(a(i, 1)) Then
                        Set dico(cle)(a(i, 1)) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not dico(cle)(a(i, 1)).exists(a(i, 4)) Then
                        ReDim w(1 To 4)
                        w(1) = a(i, 1): w(3) = a(i, 4)
                    Else
                        w = dico(cle)(a(i, 1))(a(i, 4))
                    End If
                    w(2) = w(2) + a(i, 5)
                    w(4) = w(2) * w(3)
                    dico(cle)(a(i, 1))(a(i, 4)) = w
                End If
            Next
        Next
    End With
    Application.ScreenUpdating = False
    'restitution dans la feuille cible
    With Sheets("Synthese")
        For Each e In Array(Array("achat", "a3"), Array("vente", "g3"))
            With .Range(e(1))
                .CurrentRegion.Offset(2).ClearContents
                For Each s In dico(e(0))
                    .Offset(n).Resize(UBound(Application.Transpose(dico(e(0))(s).items), 2), _
                                      UBound(Application.Transpose(dico(e(0))(s).items), 1)).Value = _
                                      Application.Transpose(Application.Transpose(dico(e(0))(s).items))
                    n = n + dico(e(0))(s).Count
                Next
            End With
            n = 0
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Il ne faut pas placé le code dans le Thisworkbook mais dans un module standard

Le code du bouton doit aussi figuré dans le module de la feuille concernée

Là, tu m'as embrouillé , j'aurais pu l'écrire autrement

klin89

Le 28/12/2017 à 09:41

Bonjour Klin89 desolé si j'ai gaffé en fait je m'y connais pas trop en macro j'ai juste un aperçu de la chose

J'ai suivis des recommandations cependant le nouveau code fausse un peu les données.

excel capture code
Rechercher des sujets similaires à "macro synthetique copier coller somme fonction criteres"