Cumul par code

Bonsoir,

A partir d'une feuille regroupant toute les opérations effectuées (debit- credit).

Je voudrais dispatcher les données sur 2 feuille débit sur feuille depense et crédit sur feuille recette,

et en cumulant les montants suivant le code.

J'ai utilisé un dictionnaire pour les codes et somme.si, J'obtiens des résultats justes.

Mais il me manque à récupérer les dates et les montants (col11).

En m'inspirant d'un exemple http://boisgontierjacques.free.fr/fichiers/Cellules/DoublonsDico.xls

Je me suis emmêlé sans y parvenir.

'Option Explicit
Sub test()
    Dim derlig As Integer, NBd As Long
    Dim TotRec As Currency, TotDep As Currency, Solde As Currency
    Dim ShBd As Worksheet, ShDep As Worksheet, ShRec As Worksheet
    Dim c As Range, d1 As Object
    Dim dl1 As Long, dl2 As Long
    Dim Tbd()

    Application.ScreenUpdating = False

    Set ShBd = Worksheets("bd")
    Set ShDep = Worksheets("depense")
    Set ShRec = Worksheets("recette")
    Set d1 = CreateObject("Scripting.Dictionary")    'code

    dl1 = ShDep.Cells(ShDep.Rows.Count, 2).End(xlUp).Row
    dl2 = ShRec.Cells(ShDep.Rows.Count, 2).End(xlUp).Row

    If dl1 > 1 Then ShDep.Range("A2:I" & dl1).Rows.Delete
    If dl2 > 1 Then ShRec.Range("A2:I" & dl2).Rows.Delete
    derlig = 2

    With ShBd
        NBd = .Cells(ShBd.Rows.Count, 1).End(xlUp).Row
        Tbd = .Range("A2:K" & NBd).Value
        ReDim Preserve Tbd(1 To UBound(Tbd, 1), 1 To UBound(Tbd, 2))
        'essai ainsi d'après exemple de Boisgontier
        '            For i = 1 To UBound(Tbd, 1)
        '                If Tbd(i, 10) = "débit" Then
        '                    If Not d1.exists(Tbd(i, 3)) Then
        '                        d1.Add (Tbd(i, 3)), Array(Tbd(i, 3), Tbd(i, 4), Tbd(i, 1), Tbd(i, 11))
        '                        'd.Item(a(i, 4)) = Array(a(i, 3), a(i, 4), a(i, 1), a(i, 11))
        '                    End If
        '                End If
        '            Next i
        For Each c In .Range("C2:C" & NBd)
            If c.Offset(0, 7).Value = "débit" Then
                If Not d1.exists(c.Value) Then
                    d1.Add (c.Value), c.Offset(, 1).Value
                End If
            End If
        Next c
    End With
    ''''''''''''''''''''''''''''''
    k = d1.keys
    i = d1.items
    For n = 0 To d1.Count - 1
        TotDep = WorksheetFunction.SumIfs(ShBd.Range("F2:F" & NBd), ShBd.Range("J2:J" & NBd), _
                                          ">=" & "débit", ShBd.Range("C2:C" & NBd), "=" & k(n))
        If TotRec <> 0 Or TotDep <> 0 Then
            ShDep.Cells(derlig, 1) = k(n)   'code
            ShDep.Cells(derlig, 2) = i(n)   'designation
            'ShDep.Cells(derlig, 3) = ?   'date plus récente
            'ShDep.Cells(derlig, 4) = ?      'colonne 11 en bd
            ShDep.Cells(derlig, 5) = TotDep
            ShDep.Cells(derlig, 6) = TotRec - TotDep
            derlig = derlig + 1
        End If
    Next n

End Sub

En vous remerciant par avance.

Bonsoir CP4, bonsoir le forum,

Pas très logique ! Tu veux cumuler par code mais garder les dates ?!... C'est plus du cumul alors c'est juste un tri par code à la fin...

Bonjour,

voulez-vous mettre les info sous cette forme

ou bien concatener les valeurs de Tbd(i, 3)), Tbd(i, 3), Tbd(i, 4), Tbd(i, 1) et Tbd(i, 11)

en un seule valeur à ajouter au dico ?

Bonjour,

Je voudrais cumuler par "articles" (à chaque article correspond un code numérique), et dispatcher sur feuille différentes sur les cas débit ou crédit (col J).

ex: code 6111 correspond à machine irait sur feuille dépense dans cet ordre

feuil depense----->col A-----------Col B----------col C----------col D-------col E------- col F

---------------------- 6111-----------machine----06/01/2017-----14000-------210--------13791 (calculé=colD-ColE)

feuil bd------------>Col C----------Col D----------col A-----------Col K------col F (correspondance des colonnes)

Je suis parvenu à alimenter les colonnes A(code), B(désignation) et E(cumul)

il me manque la date la plus récente (en faisant mon fichier, bêtise j'ai mis des dates identiques) colC et le budget col D.

C'est en quelque sorte avoir les sous totaux par familles(débit/crédit) et par articles.

Merci, j'espère avoir bien exposé le problème.

Bonjour,

je ne suis pas certaine d'avoir bien compris votre démarche, voici ma réflexion,

                    For i = 1 To UBound(Tbd, 1)
                        If Tbd(i, 10) = "débit" Then
                            For y = 0 To 3
                                Cle = Tbd(y, 3)
                                valeur = a(y, 3)
                                If Not d1.exists(Cle) Then d1.Add Cle, valeur
                            Next y
                        End If
                    Next i

Bonjour SabV,

Merci pour ton essai. Moi aussi, je n'ai pas bien compris ton code.

Voilà, je réessaie d'expliquer le résultat auquel je voudrais aboutir. Sur la feuille bd figurent des opérations, débit (dépenses) et crédit (recettes). Le but est de mettre les débits et crédits dans 2 feuilles distinctes et ensuite sur chaque feuille, effectuer des sous-totaux par code ou désignation (chaque code a une désignation =article acheté ou vendu).

Initialement, sur la feuille bd la colonne "type" (col J) n'existait pas, je l'ai rajouté pour faciliter le traitement, différentier débit/crédit.

Je t'avoue que mon niveau vba est des plus élémentaires. J'ai commencé sur la feuille avec une formule 'Somme.Si'.

Et vu que j'ai un grand nombre de lignes à traiter, j'ai voulu faire une macro partant de la fonction SumIfs.

La difficulté est plus grande (enfin, pour moi) parce que la position des colonnes de départ et d'arrivée est différente.

Je ne sais pas vraiment, si j'étais été plus clair.

Merci beaucoup.

Bonsoir le fil, bonsoir le forum,

J'ai commencé par sélectionner la colonne C (date) dans chaque onglet et la formater avec un format de date. Puis les colonnes E et F de chaque onglet et leur donner un format monétaire. Puis le code ci-dessous :

Option Explicit 'oblige à déclarer toutes les variables

Sub test()
Dim BD As Worksheet, D As Worksheet, R As Worksheet 'déclare les variables BD, R et D (onglets)
Dim DI As Object 'déclare la variable DI (DIctionaire)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Long, J As Long 'déclare les variables I et J (Incréments)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim KD As Long, KC As Long 'déclare les variables KD et KC (incréments)
Dim DT As Long 'déclare la variable DT (DaTe)
Dim TD() As Variant, TC() As Variant 'déclare les variables TD et TC (tableaux Débit & Crédit)
Dim TESTD As Boolean, TESTC As Boolean 'déclare les variables TESTD et TESTC (TEST Débit & Crédit)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set BD = Worksheets("bd") 'définit l'onglet BD
Set D = Worksheets("depense") 'définit l'onglet D
Set R = Worksheets("recette") 'définit l'onglet R
Set DI = CreateObject("Scripting.Dictionary") 'définit le dictionnaire DI
'D.Unprotect 1234
D.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface d'éventuelles anciennes données dans l'onglet D
R.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'efface d'éventuelles anciennes données dans l'onglet R
TV = BD.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    DI(TV(I, 3)) = "" 'alimente le dictionnaire DI avec les données en colonne 3 du tableau des valeurs TV (les codes)
Next I 'prochaine ligne de la boucle
TMP = DI.keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire DI sans doublon
KD = 1: KC = 1 'initilise les variable KD et KC
For J = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments du tableau temporaire TMP
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        DT = DateSerial(Year(TV(I, 1)), Month(TV(I, 1)), Day(TV(I, 1))) 'définit la date DT (tranformée en entier Long)
        'condition 1 : si la donnée ligne I colonne 3 de TV est égale à l'élément TMP(J) et que le type est "débit"
        If TV(I, 3) = TMP(J) And TV(I, 10) = "débit" Then
            ReDim Preserve TD(1 To 6, 1 To KD) 'redimensionne le tableau des débits TD (6 lignes, KD colonnes)
            TD(1, KD) = TV(I, 3) 'récupère dans la ligne 1 de TD la donnée en colonne 3 de TV (=Transposition)
            TD(2, KD) = TV(I, 4) 'récupère dans la ligne 2 de TD la donnée en colonne 4 de TV (=Transposition)
            'récupère dans la ligne 3 de TD la date la plus ancienne de la boucle (en colonne 1 de TV)
            TD(3, KD) = IIf(DT > TD(3, KD), DT, TD(3, KD))
            TD(4, KD) = TV(I, 11) 'récupère dans la ligne 4 de TD la donnée en colonne 11 de TV (=Transposition)
            TD(5, KD) = TD(5, KD) + TV(I, 6) 'récupère dans la ligne 5 de TD la somme des données en colonne 6 de TV
            TD(6, KD) = -TD(5, KD) 'récupère dans la ligne 6 de TD la valeur négative de la somme des données en colonne 6 de TV
            TESTD = True 'définit la variable TESTD
        End If 'fin de la condition 1
        'condition 2 : si la donnée ligne I colonne 3 de TV est égale à l'élément TMP(J) et que le type est "crédit"
        If TV(I, 3) = TMP(J) And TV(I, 10) = "crédit" Then
            ReDim Preserve TC(1 To 6, 1 To KC) 'redimensionne le tableau des crédits TC (6 lignes, KC colonnes)
            TC(1, KC) = TV(I, 3) 'récupère dans la ligne 1 de TC la donnée en colonne 3 de TV (=Transposition)
            TC(2, KC) = TV(I, 4) 'récupère dans la ligne 2 de TC la donnée en colonne 4 de TV (=Transposition)
            'récupère dans la ligne 3 de TC la date la plus ancienne de la boucle (en colonne 1 de TV)
            TC(3, KC) = IIf(DT > TC(3, KC), DT, TC(3, KC))
            TC(4, KC) = TV(I, 11) 'récupère dans la ligne 4 de TC la donnée en colonne 11 de TV (=Transposition)
            TC(5, KC) = TC(5, KC) + TV(I, 7) 'récupère dans la ligne 5 de TC la somme des données en colonne 7 de TV
            TC(6, KC) = TC(5, KC) 'récupère dans la ligne 5 de TC la somme des données en colonne 7 de TV
            TESTC = True 'définit la variable TESTC
        End If 'fin de la condition 2
    Next I 'prochaine ligne de la boucle 2
    If TESTD = True Then TESTD = False: KD = KD + 1 'incrémente KD si TESTD est [Vrai] et réinitialise TESTD
    If TESTC = True Then TESTC = False: KC = KC + 1 'incrémente KC si TESTC est [Vrai] et réinitialise TESTC
Next J 'prochain élément de la boucle 1
'si KD est supériere à 1 renvoie dans la A2 redimensionnée de l'onglet D, le tableau TD transposé
If KD > 1 Then D.Range("A2").Resize(UBound(TD, 2), 6) = Application.Transpose(TD)
'si KC est supériere à 1 renvoie dans la A2 redimensionnée de l'onglet R, le tableau TC transposé
If KC > 1 Then R.Range("A2").Resize(UBound(TC, 2), 6) = Application.Transpose(TC)
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Bonsoir ThauTheme,

Je te remercie infiniment pour ton remarquable travail.

Toute ma reconnaissance, pour tes explications. Les résultats sont là.

J'ai vérifié sur le fichier joint et c'est bon, à l'exception du solde que j'ai pu corriger.

Par contre, le format des dates sur les feuilles, c'est le numéro de série des dates.

Je ne suis pas parvenu à corriger. Pourrais-tu m'indiquer une procédure pour y remédier.

Sinon, tout est parfait. Mille mercis.

Bonne soirée.

Re,

Si tu relis mon second post, tu verras que je t'indique comment y remédier :

• Sélectionne la colonne des dates (la colonne C entière)
• Dans le ruban Accueil / Format / Format de Cellule... (ou le raccourci clavier [Ctrl]+[1])
• Choisit la Catégorie Date
• Choisit le Type désiré (j'ai pris celui proposé par défaut dans cette catégorie *14/03/2001

Si je ne n'utilise pas la date convertie en entier de type Long, on se retrouve au final avec certaines dates inversées. Par exemple le 10/01/2017 devient 01/10/2017...

Merci beaucoup Thautheme, je ne vais pas te prendre plus de temps.

Manuellement, je sais le faire. merci.

En effet, le problème d'inversion de date est des plus empoisonnants. Surtout pour des novices tel que moi.

Encore merci, je trouverai un moyen surtout que le nombre de lignes change.

Bonne soirée.

Bonjour CP, bonjour le forum,

En faisant comme je t'ai dit, chez moi ça marche. Regarde...

c'est parfait mon cher Thauthème.

Tous mes remerciements.

à bientôt.

Bonsoir Robert, CP4, sabV

Une chose me chiffone, quelle date doit-on conserver?

Version : un dictionnaire parent et son dictionnaire enfant :

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, e, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("bd").Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 10)) Then
                ReDim w(1 To 5)
                ReDim b(1 To UBound(a, 1), 1 To 6)
                Set w(1) = CreateObject("Scripting.Dictionary")
                w(2) = 1
                If LCase(a(i, 10)) = "débit" Then
                    w(3) = 6: w(4) = "depenses"
                End If
                If LCase(a(i, 10)) = "crédit" Then
                    w(3) = 7: w(4) = "recettes"
                End If
                b(w(2), 1) = "code": b(w(2), 2) = "désignation": b(w(2), 3) = "date"
                b(w(2), 4) = "bud": b(w(2), 5) = a(i, 10): b(w(2), 6) = "solde"
                w(5) = b
                dico.Item(a(i, 10)) = w
            End If
            w = dico.Item(a(i, 10))
            b = w(5)
            If Not w(1).exists(a(i, 3)) Then
                w(2) = w(2) + 1
                b(w(2), 1) = a(i, 3): b(w(2), 2) = a(i, 4)
                b(w(2), 3) = a(i, 1): b(w(2), 4) = a(i, 11)
                b(w(2), 6) = a(i, 11)
                w(1)(a(i, 3)) = w(2)
            End If
            b(w(1)(a(i, 3)), 5) = b(w(1)(a(i, 3)), 5) + a(i, w(3))
            If w(3) = 6 Then b(w(1)(a(i, 3)), 6) = b(w(1)(a(i, 3)), 6) - a(i, w(3))
            If w(3) = 7 Then b(w(1)(a(i, 3)), 6) = b(w(1)(a(i, 3)), 6) + a(i, w(3))
            w(5) = b
            dico.Item(a(i, 10)) = w
        Next
    End With
    For Each e In dico.keys
        dico.key(e) = dico.Item(e)(4)
    Next
    Application.ScreenUpdating = False
    For Each e In dico.keys
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(e).Delete
        Sheets.Add().Name = e
        On Error GoTo 0
        With Sheets(e).Cells(1)
            With .Resize(dico.Item(e)(2), UBound(dico.Item(e)(5), 2))
                .Value = dico.Item(e)(5)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .Font.Name = "calibri"
                .Font.Size = 9
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 6
                    .RowHeight = 16
                    .Font.Size = 10
                End With
                .Columns.AutoFit
            End With
        End With
    Next
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Un grand merci Klin89

On doit garder la date la plus récente (dernière date ou plus grande).

Il se fait tard et plus d'énergie. Vraiment à plat, je testerai demain et te mets au courant.

Très sympa de ta part

Bonjour Klin89,

Dès mon réveil, je me suis empressé de tester ton code, les résultats sont bons.

J'ai fait la bêtise de trier les dates sur le fichier joint, donc c'est la première date qui renvoyée par le code.

Or, je vous prendre la dernière date de l'achat ou vente d'un article (dernière opération -->date la plus récente).

Comme tu as utilisé des dictionnaires que je ne maitrise pas parfaitement, merci de m'indiquer comme y remédier.

Encore merci. Bonne journée.