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,
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...
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.