Bonsoir à tous et toi le forum,
je viens vous solliciter pour une petite modification de la macro qui m'avait été proposée par KJIN qui fonctionne du tonnerre.
Mais voilà je veux continuer a améliorer mon tableau.
Je vous joins un fichier qui sera plus explicite.
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
Dans l'attente merci
je viens vous solliciter pour une petite modification de la macro qui m'avait été proposée par KJIN qui fonctionne du tonnerre.
Mais voilà je veux continuer a améliorer mon tableau.
Je vous joins un fichier qui sera plus explicite.
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
Dans l'attente merci
