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 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
| Public Sub Addition()
Dim lgLastLig As Long, lgNbre As Long, lgNbre2 As Long
Dim intResult As Integer, x As Integer, y As Integer, NbreResult As Integer, i As Integer, intNbreVides As Integer, intNbreChar As Integer, NbreResult1 As Integer, intResultWrite As Integer
Dim btCmptChar As Byte, btRankChar As Byte
intResultWrite = 1
intNbreVides = 0
NbreResult = 0
intRankTab2 = 0
With Worksheets("Feuil1") 'à adapter
'Ligne de la dernière cellule remplie de la colonne A
lgLastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
'Tri par ordre croissant
n = lgLastLig - 1
lgNbre = (n * (n + 1) / 2) - 1
ReDim Tab1(lgNbre) As String
For x = lgLastLig To 2 Step -1
For y = x - 1 To 1 Step -1
NbreResult = Cells(x, "A") + Cells(y, "A")
Select Case NbreResult
Case Is < 50
Tab1(i) = NbreResult & "/" & x & "/" & y
i = i + 1
Case Is = 50
Cells(intResultWrite, "B") = "Ligne " & x & " Ligne " & y
intResultWrite = intResultWrite + 1
Case Is > 50
Tab1(i) = ">" & NbreResult & "/" & x & "/" & y
i = i + 1
Case Else
End Select
Next y
Next x
For i = 0 To lgNbre
If (Tab1(i) = "") Or (Mid(Tab1(i), 1, 1) = ">") Then
intNbreVides = intNbreVides + 1
For j = i To lgNbre - 1
Tab1(j) = Tab1(j + 1)
Next j
End If
Next i
For i = lgNbre To (lgNbre - intNbreVides + 1) Step -1
Tab1(i) = ""
Next i
lgNbre = lgNbre - intNbreVides
lgNbre2 = (lgNbre + 1) * (lgLastLig - 2)
ReDim Tab2(lgNbre2) As String
intNbreVides = 0
For i = lgNbre To 0 Step -1
ReDim intLig(9) As Integer
btRankChar = 0
'définition des Nos de lignes déjà utilisées afin de ne pes les recompter dans l'adition.
intNbreChar = Len(Tab1(i))
a = 1
While Mid(Tab1(i), a, 1) <> "/"
a = a + 1
Wend
NbreResult = Mid(Tab1(i), 1, a - 1)
For a = 1 To intNbreChar
While Mid(Tab1(i), a, 1) <> "/"
a = a + 1
Wend
c = a + 1
If Mid(Tab1(i), c, 1) <> "/" Then
btCmptChar = 1
While Mid(Tab1(i), c + btCmptChar, 1) <> "/" And Mid(Tab1(i), c + btCmptChar, 1) <> ""
btCmptChar = btCmptChar + 1
Wend
End If
intLig(btRankChar) = Mid(Tab1(i), c, btCmptChar)
btRankChar = btRankChar + 1
If Mid(Tab1(i), c + 1, 1) <> "" Then
Else
GoTo Sortie
End If
Next a
Sortie: 'Fin de définition des Nos de lignes déjà utilisées afin de ne pes les recompter dans l'adition.
For x = lgLastLig To 1 Step -1
For t = 9 To 0 Step -1
If intLig(t) = x Then
GoTo PassLig
End If
Next t
'comparaison
NbreResult1 = NbreResult + Cells(x, "A")
Select Case NbreResult1
Case Is < 50
Tab2(intRankTab2) = NbreResult1 & "/" & intLig(0) & "/" & intLig(1) & "/" & x
intRankTab2 = intRankTab2 + 1
Case Is = 50
Cells(intResultWrite, "B") = "Ligne " & intLig(0) & " Ligne " & intLig(1) & " Ligne " & x
intResultWrite = intResultWrite + 1
intNbreVides = intNbreVides + 1
Case Is > 50
Tab2(intRankTab2) = ""
'intRankTab2 = intRankTab2 + 1
intNbreVides = intNbreVides + 1
Case Else
End Select
PassLig:
Next x
Next i
MsgBox "A suivre :)"
End With
End Sub |
Partager