Sub alerte()
Dim ta, tb() As Variant
Dim rng As Range
Dim i%, j%, k%, x%, y%, m%, n%
Dim dl#
n = 3
With Sheets("BD")
Application.ScreenUpdating = False
Set rng = .Range("A2:G" & .Range("B65000").End(xlUp).Row)
rng.Sort Key1:=.Range("D2"), Order1:=xlAscending, Key2:=.Range("E2"), _
Order2:=xlAscending, Key3:=.Range("B2"), Order2:=xlAscending, Header:=xlGuess
ta = rng.Value
rng.Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess
For i = 2 To UBound(ta, 1)
k = i - 1
If ta(i, 4) = ta(k, 4) And ta(i, 5) = ta(k, 5) Then
For j = k To UBound(ta, 1)
If ta(j, 4) = ta(k + 1, 4) And ta(j, 5) = ta(k + 1, 5) Then
y = y + 1
Else: Exit For: End If
Next
If y > 3 Then
x = x + 1
ReDim Preserve tb(1 To 12, 1 To x)
tb(1, x) = ta(k, 4)
tb(2, x) = ta(k, 5)
For m = k To k + y - 1
tb(n, x) = ta(m, 2)
n = n + 1
Next
n = 3
i = m
End If
k = 0
y = 0
End If
Next
End With
With Sheets("Alerte")
'ou effacer les données existantes
'et inscrire les nouvelles à partir de A3 --> décocher(1)et(2) et cocher(3)
.Range("A3:L65000").ClearContents '(1)
dl = 3 '(2)
'ou les rajouter après la derniere ligne --> décocher(3) et cocher(1)et(2)
'dl = .Range("A65000").End(xlUp).Row + 1 '(3)
For i = 1 To UBound(tb, 2)
.Cells(dl, 1) = tb(1, i)
.Cells(dl, 2) = tb(2, i)
For j = 3 To UBound(tb, 1)
If Not IsEmpty(tb(j, i)) Then
.Cells(dl, j) = CDate(tb(j, i))
Else: Exit For: End If
Next
dl = dl + 1
Next
End With
End Sub
