Option Explicit
Sub tata()
Dim a%, b%, c%, d%, e%, f4#, f5#, g%, h#, i&, s(), t(), u(), v As New Collection
i = 125
t = Cells(5, 3).Resize(i, 7).Value
ReDim u(1 To UBound(t), 2)
s = Cells(2, 10).Resize(, 11).Value
v.Add Item:=0, Key:=CStr(s(1, 1))
On Error GoTo Z
For a = 3 To 11: v.Add Item:=0, Key:=CStr(s(1, a)): Next
On Error GoTo 0
For d = 1 To i
For e = 1 To 4
If t(d, e) = s(1, 1) Then Exit For
Next
If e < 5 Then
c = 0
For a = 3 To 11
g = s(1, a)
For b = 1 To 4
If g = t(d, b) Then Exit For
Next
c = c - (b < 5)
Next
If c > 2 Then f4 = f4 + t(d, 6): u(d, 0) = t(d, 6): u(d, 2) = t(d, 6)
End If
For e = 1 To 5
If t(d, e) = s(1, 1) Then Exit For
Next
If e < 6 Then
c = 0
For a = 3 To 11
g = s(1, a)
For b = 1 To 5
If g = t(d, b) Then Exit For
Next
c = c - (b < 6)
Next
If c > 3 Then f5 = f5 + t(d, 7): u(d, 1) = t(d, 7): u(d, 2) = u(d, 2) + t(d, 7)
End If
Next
Y: Cells(2, 21).Resize(, 3).Value = Array(f4, f5, f4 + f5)
Cells(5, 21).Resize(i, 3).Value = u
Exit Sub
Z:
MsgBox "Données incohérentes."
Resume Y
End Sub
Private Sub tutu0() 'Variante de tutu.
Dim a%, b%, c%, d%, e%, f#, f4#, f5#, g%, h#, i&, j%, k%, l%, m%, n%, o%, p%, q%, r%, s%, t&, u(), v(), w()
i = 125
v = Cells(5, 3).Resize(i, 7).Value
For j = 1 To 18
For k = 1 To 10: If k = j Then k = k + 1
For l = k + 1 To 11: If l = j Then l = l + 1
For m = l + 1 To 12: If m = j Then m = m + 1
For n = m + 1 To 13: If n = j Then n = n + 1
For o = n + 1 To 14: If o = j Then o = o + 1
For p = o + 1 To 15: If p = j Then p = p + 1
For q = p + 1 To 16: If q = j Then q = q + 1
For r = q + 1 To 17: If r = j Then r = r + 1
For s = r + 1 To 18: If s = j Then s = s + 1
If s < 19 Then
t = t + 1
u = Array("", j, "", k, l, m, n, o, p, q, r, s)
f4 = 0: f5 = 0
ReDim w(1 To i, 2)
For d = 1 To i
For e = 1 To 4
If v(d, e) = u(1) Then Exit For
Next
If e < 5 Then
c = 0
For a = 3 To 11
g = u(a)
For b = 1 To 4
If g = v(d, b) Then Exit For
Next
c = c - (b < 5)
Next
If c > 2 Then f4 = f4 + v(d, 6): w(d, 0) = v(d, 6): w(d, 2) = v(d, 6)
End If
For e = 1 To 5
If v(d, e) = u(1) Then Exit For
Next
If e < 6 Then
c = 0
For a = 3 To 11
g = u(a)
For b = 1 To 5
If g = v(d, b) Then Exit For
Next
c = c - (b < 6)
Next
If c > 3 Then f5 = f5 + v(d, 7): w(d, 1) = v(d, 7): w(d, 2) = w(d, 2) + v(d, 7)
End If
Next
If f4 + f5 >= f Then
f = f4 + f5
Cells(2, 9).Resize(, 12).Value = u
Cells(2, 21).Resize(, 3).Value = Array(f4, f5, f4 + f5)
Cells(5, 21).Resize(i, 3).Value = w
End If
If t Mod 200 = 0 Then DoEvents
End If
Next s, r, q, p, o, n, m, l, k, j
Cells(3, 1).Value = t
End Sub
Private Sub tutu()
Dim a%, b%, c%, d%, e%, f#, f4#, f5#, g%, h#, i&, j%, k%, l%, m%, n%, o%, p%, q%, r%, s%, t&, u(), v(), w()
i = 125
v = Cells(5, 3).Resize(i, 7).Value
ReDim w(1)
For j = 1 To 18
For k = 1 To 10: If k = j Then k = k + 1
For l = k + 1 To 11: If l = j Then l = l + 1
For m = l + 1 To 12: If m = j Then m = m + 1
For n = m + 1 To 13: If n = j Then n = n + 1
For o = n + 1 To 14: If o = j Then o = o + 1
For p = o + 1 To 15: If p = j Then p = p + 1
For q = p + 1 To 16: If q = j Then q = q + 1
For r = q + 1 To 17: If r = j Then r = r + 1
For s = r + 1 To 18: If s = j Then s = s + 1
If s < 19 Then
t = t + 1
u = Array("", j, "", k, l, m, n, o, p, q, r, s)
f4 = 0: f5 = 0
For d = 1 To i
For e = 1 To 4
If v(d, e) = u(1) Then Exit For
Next
If e < 5 Then
c = 0
For a = 3 To 11
g = u(a)
For b = 1 To 4
If g = v(d, b) Then Exit For
Next
c = c - (b < 5)
Next
If c > 2 Then f4 = f4 + v(d, 6)
End If
For e = 1 To 5
If v(d, e) = u(1) Then Exit For
Next
If e < 6 Then
c = 0
For a = 3 To 11
g = u(a)
For b = 1 To 5
If g = v(d, b) Then Exit For
Next
c = c - (b < 6)
Next
If c > 3 Then f5 = f5 + v(d, 7)
End If
Next
If f4 + f5 >= f Then f = f4 + f5: w(0) = u: w(1) = Array(f4, f5, f)
If t Mod 200 = 0 Then DoEvents
End If
Next s, r, q, p, o, n, m, l, k, j
Cells(3, 1).Value = t
Cells(2, 9).Resize(, 12).Value = w(0)
Cells(2, 21).Resize(, 3).Value = w(1)
tata
End Sub
Private Sub test()
Dim t1!, t2!
Cells(2, 9).Resize(, 12).ClearContents
Cells(2, 1).Resize(2).ClearContents
t1 = Timer
tutu
t2 = Timer
[A2].Value = Format((t2 - t1) / 86400 - (t2 < t1), "hh:mm:ss")
End Sub
Private Sub Worksheet_Change(ByVal Cible As Range)
If Not Intersect(Cible, Range("J2, L2:T2")) Is Nothing Then
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
Cells(2, 21).Resize(, 3).Value = Empty: Cells(5, 21).Resize(125, 3).Value = Empty
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Cible As Range, Contremander As Boolean)
If Not Intersect(Cible, Range("A2:A3")) Is Nothing Then Contremander = True: test
If Not Intersect(Cible, Range("U1:W1")) Is Nothing Then Contremander = True: tata
End Sub
