Bonsoir,
Un peu de VBA alors ?
Sub ExtracProjetsARevoir()
Dim d As Object, Ext(), k, dd&, n%, i%
Set d = CreateObject("Scripting.Dictionary")
With ActiveSheet
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To n
k = .Cells(i, 1): dd = IIf(.Cells(i, 5) > 0, .Cells(i, 3).Value2, 0)
If d.exists(k) Then
If dd > CLng(d(k)) Then d(k) = dd
Else
d(k) = dd
End If
Next i
End With
dd = CLng(DateAdd("yyyy", -1, Date))
For Each k In d.keys
If CLng(d(k)) > dd Then d.Remove (k)
Next k
If d.Count > 0 Then
ReDim Ext(d.Count, 1): n = 0
Else
MsgBox "Pas de projets non vus depuis un an ou plus à ce jour.", vbInformation, _
"Examen Projets"
Exit Sub
End If
For Each k In d.keys
n = n + 1: Ext(n, 0) = k: Ext(n, 1) = CLng(d(k))
Next k
Ext(0, 0) = "Projets à revoir": Ext(0, 1) = "Dernière date d'examen"
Application.ScreenUpdating = False
With Worksheets.Add(after:=ActiveSheet)
With .Range("A1").Resize(UBound(Ext, 1) + 1, 2)
.Value = Ext
.Columns.ColumnWidth = 15
.WrapText = True
.HorizontalAlignment = xlCenter
.Rows(1).Font.Bold = True
.Columns(2).NumberFormat = "dd/mm/yyyy"
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
.Activate
End With
End Sub
Cordialement.