besoin aide pour modifier macro

fred94000

XLDnaute Junior
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
 

Pièces jointes

  • fred-1.xls
    63.5 KB · Affichages: 74

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 011
Membres
101 866
dernier inscrit
XFPRO