Automatisation macro VBA traitement données (montant + et -)

Version imprimable

02/06/2020, 21h05
chacha78

1 pièce(s) jointe(s)

Automatisation macro VBA traitement données (montant + et -)

Bonjour à tous,

je vous remercie tout d'abord pour votre aide. j'ai besoin d'automatiser des taches récurrentes de traitement de données Excel via une macro. (je suis sur Excel 365 Pro.
je débute dans les macro VBA. A partir d'un tableau de données (chaque ligne est une opération comptable), je dois identifier/isoler les opérations à corriger.

Je vous ai simplifié mon tableau (voir le fichier xls). J'ai nommé la colonne A : PIECE, B : REFERENCE, C : MONTANT
Sur les références identiques (ex=RE54), si la somme des opérations est égale à 0 --> il ne faut pas les sélectionner, sinon si la somme des opérations est différent de 0 --> afficher chaque ligne PIECE/REFERENCE/MONTANT.
Comment faire s'il y a 10000 lignes à analyser.
PS : comment se fait il que je n'ai pas les fonctions Filtre() et TRIER()
je vous remercie pour votre aide précieuse et vos lumières.
Si vous avez d'autres pistes de traitement, je suis preneuse.
Bonne soirée.

Bonjour,

Vous oubliez de préciser si on doit supprimer les lignes. Voici le code pour supprimer les lignes dont le montant total est nul pour une même référence.
le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Controle()
    Dim L As Long, I As Long, DerLig As Long
    Dim Diff As Boolean
    Dim Total As Double
    Dim Ref As String
 
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    L = DerLig - 1
    For I = DerLig To 3 Step -1
        Ref = Cells(I, "B")
        Total = Cells(I, "C")
        L = I - 1
        Diff = False
        Do While Cells(L, "B") = Ref
            Diff = True
            Total = Total + Cells(L, "C")
            L = L - 1
        Loop
        If Diff = True And Cells(L + 1, "B") = Ref And Total = 0 Then
            Range(Cells(I, "A"), Cells(L + 1, "C")).Delete
            I = L + 1
        End If
    Next I
End Sub

le fichier en exemple
Pièce jointe 569745

Cdlt

03/06/2020, 09h03
chacha78

Bonjour ARTURO83,

Je vous remercie pour votre macro. Effectivement je n'avais pas précisé si la macro devait annuler les lignes qui avaient la même référence et dont la somme est nulle. la réponse est non. Car je dois garder les données d'origine vierge et je dois appliquer d'autres règles sur ces même données. En tout cas je vous remercie pour votre travail.
Je vous souhaite une bonne journée.

1 pièce(s) jointe(s)

La macro n'efface pas toutes les lignes qui s'annulent

Bonjour ARTURO83,
Je me permets de revenir vers vous car la macro que vous m'avez envoyé n'efface pas toutes les lignes (ayant la même référence) et qui s'annulent.
J'ai bien sur adapté votre macro.
Y a t il une erreur quelque part ? Pouvez vous y jeter un œil svp ? Merci beaucoup. Je vous joins mon fichier.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Control()
Dim L As Long, I As Long, DerLig As Long
    Dim Diff As Boolean
    Dim Total As Double
    Dim Ref As String
 
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    L = DerLig - 1
    For I = DerLig To 2 Step -1
        Ref = Cells(I, "G")
        Total = Cells(I, "H")
        L = I - 1
        Diff = False
        Do While Cells(L, "G") = Ref
            Diff = True
            Total = Total + Cells(L, "H")
            L = L - 1
        Loop
        If Diff = True And Cells(L + 1, "G") = Ref And Total = 0 Then
            Range(Cells(I, "A"), Cells(L + 1, "Z")).Delete
            I = L + 1
        End If
    Next I
End Sub

Bonjour,

Hormis le fait que mon code saute des lignes, vous vous contredisez, au départ, vous ne vouliez pas effacer les lignes dont le total s'annulaient, et puis dans le dernier post vous dites qu'elles ne s'effacent pas!!!

Voici la modif, les lignes dont les totaux =0 passent en jaune. Cliquez sur le bouton "Contrôle" pour lancer la macro.
le fichier
Pièce jointe 574622

Le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Sub Control()
    Dim L As Long, I As Long, DerLig As Long
    Dim Diff As Boolean
    Dim Total As Currency
    Dim Ref As String
 
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
 
    'Marquage pour restituer la configuration initiale après traitement
    Range("Y2") = 1
    Range("Y2").AutoFill Destination:=Range("Y2:Y" & DerLig), Type:=xlFillSeries
    Range("W2:W" & DerLig).FormulaR1C1 = "=ABS(RC[-15])"
 
    'Numerotation des lignes pour alterner les valeurs positives et négatives
    Range("X2") = 1
    For I = 3 To DerLig
        If Cells(I, "H") <> Cells(I - 1, "H") Then
            Cells(I, "X") = Application.Max(Range("X2:X" & I - 1)) + 1
        Else
            If Cells(I, "H") = Cells(I - 1, "H") Then
                Cells(I, "X") = Application.Max(Range("X2:X" & I - 1)) + 2
                Cells(I + 1, "X") = Application.Max(Range("X2:X" & I + 1)) - 1
                I = I + 1
            End If
        End If
    Next I
    Range("W2:X" & DerLig).Value = Range("W2:X" & DerLig).Value
 
    'Tri par référence et par Val.variable converties en positif en colonne W
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("G2:G" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("W2:W" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("X2:X" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A1:Y" & DerLig)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    L = DerLig - 1
    For I = DerLig To 2 Step -1
        Ref = Cells(I, "G")
        Total = Cells(I, "H")
        L = I - 1
        If L = 0 Then Exit For
        Diff = False
        Do While Cells(L, "G") = Ref
            Diff = True
            Total = Cells(I, "H")
            If Diff = True And Cells(L, "G") = Ref And Total + Cells(L, "H") = 0 Then
                Range(Cells(I, "A"), Cells(L, "Y")).Interior.ColorIndex = 6  'Delete
                Total = 0
                I = I - 1
            End If
            I = I - 1
            L = I - 1
            If L = 0 Then Exit For
        Loop
        If Cells(I, "G") <> Ref Then I = I + 1
    Next I
 
    '2ème passage de contrôle
    For I = DerLig To 2 Step -1
        Ref = Cells(I, "G")
        If Cells(I, "H").Interior.ColorIndex <> 6 Then
            Total = Cells(I, "H")
            Lig = I - 1
            Do While Cells(Lig, "G") = Ref And Cells(I, "H").Interior.ColorIndex <> 6 And Cells(Lig, "H").Interior.ColorIndex <> 6
                Total = Round(Total, 2) + Round(Cells(Lig, "H"), 2)
                Lig = Lig - 1
            Loop
            If Total = 0 Then
                Range(Cells(I, "A"), Cells(Lig + 1, "Y")).Interior.ColorIndex = 6
                I = Lig + 1
            End If
        End If
    Next I
 
    'Restitution de la configuration initiale
    Range("A2:Y" & DerLig).Sort [Y1], 1
    Columns("W:Y").Clear
End Sub

Cdlt