XL 2013 Ventilation des montants sur un mois précis

an@s · 28 Janvier 2019

Bonjour à tous,
je reviens vers vous pour solliciter votre aide concernant ma problématique de ventilation des montants.
dans le fichier ci-joint j'ai une feuille RECAP qui englobe toutes les données qui seront dispatchées dans les autres feuilles.

j'aimerais avoir un code qui me permettra lorsque je renseigne le mois souhaité dans K1 (Feuille RECAP) de :

Ventiler les données de la colonne C de la feuille Recap dans la feuille Concernée en se basant sur le code de la colonne D qui est le même nom de la feuille de destination
Ventiler les montants de la colonne E de la feuille RECAP dans le même mois que K1 dans la feuille concernée en se basant sur le code de la colonne D qui est le même nom de la feuille de destination
dans la colonne AO je dois avoir les mêmes montants copiés automatiquement comme j'ai fait manuellement en renseignant le nom du mois dans la cellule AO2
dans la colonne AP je dois avoir les montants du même mois mais de l'année précédente c'est à dire les mois qui sont entre N & Y

Exemple: dans K1 j'ai mis Juin-2018 donc dans la feuille DT par exemple les montants des colonnes C & E (feuille recap) sont mentionnés dans les colonnes C & G .
puis les mêmes données de la colonne G (feuille DT) sont mentionnées dans AO en mettant dans AO2 le nom du mois et l'année.
ensuite les données du même mois mais de l'année écoulée sont mentionnées dans AP en mettant dans AP2 le nom du mois et lannée.

NB: de préférence que les données du tableau AN: AS soit en valeur et pas en formule

Merci d'avance pour votre aide

Cordialement
An@s

job75 · 28 Janvier 2019

Bonjour an@s,

Voyez le fichier joint et cette macro :

Code:

Sub Ventilation()
If Not IsDate([K1]) Then Exit Sub
Dim an%, mois As Byte, tablo, d As Object, i&, e, F As Worksheet, col%
Dim a(), b(), n&, colBudget%, colRecap%
an = Year([K1]): mois = Month([K1])
tablo = Sheets("RECAP").[A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo): d(tablo(i, 4)) = "": Next
On Error Resume Next
For Each e In d.keys
    Set F = Nothing: Set F = Sheets(e)
    col = 0: col = Application.Match(an, F.Rows(1), 0) + mois - 1
    If col Then
        '---filtrage---
        ReDim a(1 To UBound(tablo), 1 To 1)
        ReDim b(1 To UBound(tablo), 1 To 1)
        n = 0
        For i = 2 To UBound(tablo)
            If tablo(i, 4) = e Then
                n = n + 1
                a(n, 1) = tablo(i, 3)
                b(n, 1) = tablo(i, 5)
            End If
        Next i
        '---restitution dans le 1er tableau---
        i = F.Cells(F.Rows.Count, 1).End(xlUp).Row + 1
        F.Cells(i, 1).Resize(n) = a
        F.Cells(i, col).Resize(n) = b
        With F.Rows("3:" & i + n - 1)
            .Sort .Columns(1), xlAscending, Header:=xlNo 'tri
            For i = .Rows.Count To 2 Step -1
                If .Cells(i, 1) = .Cells(i - 1, 1) Then
                    .Cells(i - 1, col) = .Cells(i, col)
                    .Rows(i).Delete 'suppression de la ligne doublon
                End If
            Next
            n = 0: n = .Rows.Count
        End With
        F.Cells(1).CurrentRegion.Borders.Weight = xlThin 'bordures
        '---remplissage du 2ème tableau---
        colBudget = Application.Match("Budget", F.Rows(1), 0)
        colRecap = Application.Match("RECAP*", F.Rows(1), 0)
        F.Cells(2, colRecap + 1) = DateSerial(an, mois, 1)
        F.Cells(2, colRecap + 2) = DateSerial(an - 1, mois, 1)
        F.Cells(3, colRecap).Resize(n) = F.Cells(3, colBudget + 11).Resize(n).Value
        F.Cells(3, colRecap + 1).Resize(n) = F.Cells(3, col).Resize(n).Value
        col = 0: col = Application.Match(an - 1, F.Rows(1), 0) + mois - 1
        F.Cells(3, colRecap + 2).Resize(n) = F.Cells(3, col).Resize(n).Value
        F.Cells(3, colRecap + 3).Resize(n) = "=RC[-3]-RC[-2]"
        F.Cells(3, colRecap + 4).Resize(n) = "=IFERROR(RC[-3]/RC[-2]-1,"""")"
        F.Cells(3, colRecap + 5).Resize(n) = "=IFERROR(RC[-4]/RC[-5],"""")"
        F.Cells(3, colRecap + 3).Resize(n, 3) = F.Cells(3, colRecap + 3).Resize(n, 3).Value 'supprime les formules
        F.Cells(3, colRecap).Resize(n, 6).Borders.Weight = xlThin 'bordures
    End If
Next e
End Sub

Pas vraiment difficile mais un peu laborieux.

A+

an@s · 28 Janvier 2019

Bonjour Job, le forum
je vous remercie pour vos réponses qui répondent parfaitement sur mes demandes.
j'ai deux petits points a rectifier :

si j'ajoute d'autres lignes dans la feuille RECAP, après l'exécution de la macro les données rajoutées (colonnes C et E) je ne les trouve pas dans les feuilles de destination..(le tableau de la feuille RECAP peut toujours être mis à jour en ajoutant ou supprimant des lignes)

dans les cellules AO2 et AP2 des feuilles de destinations je dois avoir automatiquement AO2= K1 de la feuille RECAP et AP2= le même mois mais de l'année précédente. (c'est à dire si je mets dans K1 de la feuille RECAP Septembre-2018 après l'exécution du code je dois avoir dans AO2= Septembre-2018 et dans AP2=Septembre-2017, et si je change K1 et j'exécute le code AO2 et AP2 changent aussi automatiquement)

Merci encore une autre fois pour votre aide

Cordialement
An@s

job75 · 28 Janvier 2019

Pour le 1er point vous avez probablement mal testé, les données ajoutées sont forcément ventilées.

Pour le 2ème point c'est une omission de ma part, je viens de modifier mon post #2.

an@s · 28 Janvier 2019

Bonsoir Job, le forum
vous avez raison pour ce qui concerne le 1er point par contre j'ai fait une remarque bizarre,
quand je supprime des lignes ou je remplace les données d'une ligne et je lance la macro la feuille de destination ne supprime pas les anciennes données qui n'existent plus dans la feuille RECAP,
voir fichier joint j'ai enlevé des lignes avec le code DT et en exécutant le code la feuille DT garde toujours les anciennes lignes.

job75 · 29 Janvier 2019

Bonjour an@s, le forum,

Dans les feuilles de destination il ne faut pas supprimer de lignes car il peut y avoir des montants sur les autres mois.

Par contre il faut effacer les montants du mois dont les LIBELLES n'existent pas en feuille RECAP :

Code:

Option Compare Text 'la casse est ignorée

Sub Ventilation()
If Not IsDate([K1]) Then Exit Sub
Dim an%, mois As Byte, tablo, d As Object, i&, e, F As Worksheet, col%
Dim a(), b(), n&, colBudget%, colRecap%
an = Year([K1]): mois = Month([K1])
tablo = Sheets("RECAP").[A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo): d(tablo(i, 4)) = "": Next
On Error Resume Next
For Each e In d.keys
    Set F = Nothing: Set F = Sheets(e)
    col = 0: col = Application.Match(an, F.Rows(1), 0) + mois - 1
    If col Then
        '---filtrage---
        d.RemoveAll 'nouvelle utilisation du Dictionary
        ReDim a(1 To UBound(tablo), 1 To 1)
        ReDim b(1 To UBound(tablo), 1 To 1)
        n = 0
        For i = 2 To UBound(tablo)
            If tablo(i, 4) = e Then
                n = n + 1
                d(tablo(i, 3)) = "" 'liste des LIBELLES
                a(n, 1) = tablo(i, 3)
                b(n, 1) = tablo(i, 5)
            End If
        Next i
        '---restitution dans le 1er tableau---
        i = F.Cells(F.Rows.Count, 1).End(xlUp).Row + 1
        F.Cells(i, 1).Resize(n) = a
        F.Cells(i, col).Resize(n) = b
        With F.Rows("3:" & i + n - 1)
            .Sort .Columns(1), xlAscending, Header:=xlNo 'tri
            For i = 1 To .Rows.Count
                If Not d.exists(.Cells(i, 1).Value) Then .Cells(i, col) = "" 'effacement du montant si LIBELLE non listé
                If .Cells(i, 1) = .Cells(i - 1, 1) Then .Cells(i - 1, col) = .Cells(i, col) 'si doublon
            Next i
            .RemoveDuplicates 1, Header:=xlNo 'élimine les doublons
        End With
        F.Cells(1).CurrentRegion.Borders.Weight = xlThin 'bordures
        n = F.Cells(F.Rows.Count, 1).End(xlUp).Row - 2
        F.Rows(n + 3 & ":" & F.Rows.Count).Delete 'RAZ en dessous
        With F.UsedRange: End With 'actualise la barre de défilement verticale
        '---remplissage du 2ème tableau---
        colBudget = Application.Match("Budget", F.Rows(1), 0)
        colRecap = Application.Match("RECAP*", F.Rows(1), 0)
        F.Cells(2, colRecap + 1) = DateSerial(an, mois, 1)
        F.Cells(2, colRecap + 2) = DateSerial(an - 1, mois, 1)
        F.Cells(3, colRecap).Resize(n) = F.Cells(3, colBudget + 11).Resize(n).Value
        F.Cells(3, colRecap + 1).Resize(n) = F.Cells(3, col).Resize(n).Value
        col = 0: col = Application.Match(an - 1, F.Rows(1), 0) + mois - 1
        F.Cells(3, colRecap + 2).Resize(n) = F.Cells(3, col).Resize(n).Value
        F.Cells(3, colRecap + 3).Resize(n) = "=RC[-3]-RC[-2]"
        F.Cells(3, colRecap + 4).Resize(n) = "=IFERROR(RC[-3]/RC[-2]-1,"""")"
        F.Cells(3, colRecap + 5).Resize(n) = "=IFERROR(RC[-4]/RC[-5],"""")"
        F.Cells(3, colRecap + 3).Resize(n, 3) = F.Cells(3, colRecap + 3).Resize(n, 3).Value 'supprime les formules
        F.Cells(3, colRecap).Resize(n, 6).Borders.Weight = xlThin 'bordures
    End If
Next e
End Sub

Fichier (2).

J'ai testé en dupliquant la plage A2:E28 sur 27 000 lignes : la macro s'exécute en 3,8 secondes chez moi, c'est très acceptable.

Bonne journée.

an@s · 29 Janvier 2019

Bonjour Job, le forum

dans les feuilles de destination il faut supprimer toutes les lignes qui n'existent plus dans la feuille RECAP et non pas juste les montants,
parce que dans les autres mois toutes les données de la feuille RECAP seront actualisées le mois d'après en copiant un nouveau tableau à la place de celui qui existe déjà dans la feuille RECAP.
donc toutes les données (lignes, libellé et montants des feuilles de destination doivent être actualisées en supprimant les lignes dont les libellés et les montants ne sont plus les mêmes, c'est à dire il ne faut rien garder du mois précédent il faut se baser toujours sur la base de donnée de la feuille RECAP pour ventiler.

Merci

zebanx · 29 Janvier 2019

Bonjour à tous.

Une question : Ne faudrait-il pas mieux avoir toutes les lignes avec toutes les codifications possibles et masquer (automatiquement) uniquement celles qui ne contiennent pas de données sur la période "janvier - décembre" ?

job75 · 29 Janvier 2019

Re, salut zebanx

J'ai corrigé la macro du fichier (2) : la boucle For i = 1 To .Rows.Count doit commencer à 1, pas à 2.

Puisque vous voulez supprimer les lignes sans LIBELLE listé utilisez ce fichier (2 bis) :

Code:

Option Compare Text 'la casse est ignorée

Sub Ventilation()
If Not IsDate([K1]) Then Exit Sub
Dim an%, mois As Byte, tablo, d As Object, i&, e, F As Worksheet, col%
Dim a(), b(), n&, colBudget%, colRecap%
an = Year([K1]): mois = Month([K1])
tablo = Sheets("RECAP").[A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo): d(tablo(i, 4)) = "": Next
On Error Resume Next
For Each e In d.keys
    Set F = Nothing: Set F = Sheets(e)
    col = 0: col = Application.Match(an, F.Rows(1), 0) + mois - 1
    If col Then
        '---filtrage---
        d.RemoveAll 'nouvelle utilisation du Dictionary
        ReDim a(1 To UBound(tablo), 1 To 1)
        ReDim b(1 To UBound(tablo), 1 To 1)
        n = 0
        For i = 2 To UBound(tablo)
            If tablo(i, 4) = e Then
                n = n + 1
                d(tablo(i, 3)) = "" 'liste des LIBELLES
                a(n, 1) = tablo(i, 3)
                b(n, 1) = tablo(i, 5)
            End If
        Next i
        '---restitution dans le 1er tableau---
        i = F.Cells(F.Rows.Count, 1).End(xlUp).Row + 1
        F.Cells(i, 1).Resize(n) = a
        F.Cells(i, col).Resize(n) = b
        With F.Rows("2:" & i + n - 1) 'avec la ligne de titres
            .Sort .Columns(1), xlAscending, Header:=xlYes 'tri
            For i = 2 To .Rows.Count
                If Not d.exists(.Cells(i, 1).Value) Then
                    .Cells(i, 1) = .Cells(1) 'crée un doublon si LIBELLE non listé
                ElseIf .Cells(i, 1) = .Cells(i - 1, 1) Then
                    .Cells(i - 1, col) = .Cells(i, col) 'si doublon
                End If
            Next i
            .RemoveDuplicates 1, Header:=xlNo 'élimine les doublons
        End With
        F.Cells(1).CurrentRegion.Borders.Weight = xlThin 'bordures
        n = F.Cells(F.Rows.Count, 1).End(xlUp).Row - 2
        F.Rows(n + 3 & ":" & F.Rows.Count).Delete 'RAZ en dessous
        With F.UsedRange: End With 'actualise la barre de défilement verticale
        '---remplissage du 2ème tableau---
        colBudget = Application.Match("Budget", F.Rows(1), 0)
        colRecap = Application.Match("RECAP*", F.Rows(1), 0)
        F.Cells(2, colRecap + 1) = DateSerial(an, mois, 1)
        F.Cells(2, colRecap + 2) = DateSerial(an - 1, mois, 1)
        F.Cells(3, colRecap).Resize(n) = F.Cells(3, colBudget + 11).Resize(n).Value
        F.Cells(3, colRecap + 1).Resize(n) = F.Cells(3, col).Resize(n).Value
        col = 0: col = Application.Match(an - 1, F.Rows(1), 0) + mois - 1
        F.Cells(3, colRecap + 2).Resize(n) = F.Cells(3, col).Resize(n).Value
        F.Cells(3, colRecap + 3).Resize(n) = "=RC[-3]-RC[-2]"
        F.Cells(3, colRecap + 4).Resize(n) = "=IFERROR(RC[-3]/RC[-2]-1,"""")"
        F.Cells(3, colRecap + 5).Resize(n) = "=IFERROR(RC[-4]/RC[-5],"""")"
        F.Cells(3, colRecap + 3).Resize(n, 3) = F.Cells(3, colRecap + 3).Resize(n, 3).Value 'supprime les formules
        F.Cells(3, colRecap).Resize(n, 6).Borders.Weight = xlThin 'bordures
    End If
Next e
End Sub

Sur 27 000 lignes la macro s'exécute chez moi en 4,6 secondes.

A+

an@s · 29 Janvier 2019

Re-Bonjour Job, Zebanx

je vous remercie infiniment, c'est exactement ce que je souhaitais avoir comme résultat.
je vais faire d'autres test sur une base de donnée plus grande et je reviens vers vous

Merci encore une autre fois

Cordialement
An@s

an@s · 29 Janvier 2019

Re,

après une vérification sur une base de donnée de plus de 42 000 lignes je confirme que la macro se lance rapidement.
en revanche j'ai un autre classeur ou je récupère les données que je mentionne manuellement dans la colonne AK des feuilles de destination,

je me demande est ce que ce serait possible d'avoir un code qui permet de chercher dans la ligne 1 du classeur Budget 1 le nom des feuilles qui se trouvent aussi les noms des feuilles de destinations du classeur FG et de mentionner les montants dans la colonne AK en se basant sur le libellé de la colonne B du classeur Budget 1 qui est le même libellé des feuilles de destination.

NB: si le code ne trouve pas un libellé dans la feuille de destination et qui se trouve dans le classeur budget 1 ne pas importer le montant

Merci encore une autre fois pour votre travail extraordinaire

Cordialement
An@s

job75 · 29 Janvier 2019

Fichier (3) avec cette macro :

Code:

Sub Import_Budget()
Dim fichier$, tablo, d As Object, i&, j%, F As Worksheet, a, b(), colBudget%
fichier = ThisWorkbook.Path & "\Budget 1.xlsx" 'à adapter
Application.ScreenUpdating = False
On Error Resume Next
With Workbooks.Open(fichier)
    tablo = .Sheets(1).[A1].CurrentRegion 'matrice, plus rapide
    .Close False
End With
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For j = 4 To 9 'numéros de colonnes à adapter éventuellement
    Set F = Sheets(tablo(1, j))
    a = F.Range("A3", F.Range("A" & F.Rows.Count).End(xlUp)(3)) 'matrice, plus rapide, au moins 2 éléments
    ReDim b(1 To UBound(a) - 2, 1 To 1)
    d.RemoveAll 'RAZ
    For i = 2 To UBound(tablo) - 1
        d(tablo(i, 2)) = d(tablo(i, 2)) + tablo(i, j) 'somme
    Next i
    For i = 1 To UBound(b)
        b(i, 1) = d(a(i, 1))
    Next i
    '---restitution---
    colBudget = Application.Match("Budget", F.Rows(1), 0)
    F.Cells(3, colBudget + 11).Resize(UBound(b)) = b
Next j
End Sub

an@s · 30 Janvier 2019

Bonsoir Job, le forum
c'est extraordinaire ce que j'ai eu comme résultat avec ces deux codes, cela me prenait avant au moins une demi-journée vu que j'ai une grande base de donnée de plus de 42 000 lignes, non pas juste ça mais pas mal de fois à cause de la fatigue je fais des erreurs de saisie chose qui est impossible avec votre code qui importe dans le bon coin. (je vous en remercie vivement)

j'ai une dernière demande pour compléter le fichier et éviter la saisie manuelle entre les colonnes N et Y des feuilles de destination si c'est réalisable.
le principe est d'avoir un 3ème code qui permet de chercher dans la colonne D du classeur Budget -1 les noms des feuilles qui sont les mêmes noms des feuilles de destinations du classeur FG, puis chercher dans la colonne F du classeur Budget -1 le mois qui correspond au mois qui se trouvent dans la ligne 2 des feuilles de destinations entre les colonnes N et Y et de mentionner les montants entre les colonnes N et Y en se basant sur le libellé de la colonne C du classeur Budget -1 qui est le même libellé de la colonne A des feuilles de destination.

je donne deux exemples:

D2 du classeur Budget -1 correspond à la feuille de destination DT, et F2 correspond au mois 5 c'est à dire Mai, ensuite C2 correspond à ACHATS DE PETIT OUTILLAGE ET EQUIPEMENT cela veut dire que G2 qui égale 424 sera mentionné dans F3 de la feuille DT du classeur FG
D6 du classeur Budget -1 correspond à la feuille de destination DT, et F6 correspond au mois 11 c'est à dire Novembre, ensuite C6 correspond à APPOINTEMENTS ET SALAIRES cela veut dire que G6 qui égale -3244 sera mentionné dans L7 de la feuille DT du classeur FG

je vous remercie encore une autre fois Job et je vous en serai reconnaissant à vie pour tout les codes que vous m'avez fourni et qui m'ont facilité plusieurs tâches dont je perdais du temps que ce soit pour calculer ou même saisir.

Cordialement
An@s

job75 · 30 Janvier 2019

Bonjour an@s, le forum,

Dans vos 2 exemples feuille DT vous remplissez les cellules F3 et L7, ne serait-ce pas plutôt R3 et X7 ??

S'agissant de budget j'aurais même pensé aux cellules AD3 et AJ7...

A+

an@s · 30 Janvier 2019

Bonjour JOB, le forum
vous avez raison je me suis trompé dans mes deux exemples c'est R3 et X7 qu'il faut remplir,
avec le fichier Budget -1 c'est toujours les mois qui sont entre N & Y ou les montants seront mentionnés..

Cordialement
An@s

XL 2013 Ventilation des montants sur un mois précis

an@s

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

an@s

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

an@s

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

an@s

XLDnaute Occasionnel

zebanx

XLDnaute Accro

job75

XLDnaute Barbatruc

Pièces jointes

an@s

XLDnaute Occasionnel

an@s

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

an@s

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

an@s

XLDnaute Occasionnel

Discussions similaires