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 |
Partager