Sub Extract_9_12()
Dim FS As Worksheet, FC As Worksheet
Dim DerL As Long, Nmois As Byte, i As Long, j As Long, x As Long, k As Byte
Dim Dico, Clé, Tablo, TabFin()
Set Dico = CreateObject("Scripting.Dictionary")
Set FS = Worksheets("test") 'Feuille Source. à adapter
Set FC = Worksheets("Feuil1") 'Feuille Cible. à adapter
DerL = FS.Range("A" & Rows.Count).End(xlUp).Row
FS.Range("E2:E" & DerL).NumberFormat = "General" ' format standard pour éviter les transformations en date US
Tablo = FS.Range("A2:H" & DerL)
For i = LBound(Tablo) To UBound(Tablo)
If Not Dico.exists(Tablo(i, 6)) Or Dico(Tablo(i, 6)) = True Then
Nmois = Int((Tablo(i, 5) - Date) / 30)
If Nmois < 9 Or Nmois > 12 Then
Dico(Tablo(i, 6)) = False
Else
Dico(Tablo(i, 6)) = True
End If
End If
Next
For Each Clé In Dico.keys
If Dico(Clé) = False Then Dico.Remove (Clé)
Next
If Dico.Count > 0 Then
For Each Clé In Dico.keys
For j = LBound(Tablo) To UBound(Tablo)
If Tablo(j, 6) = Clé Then
x = x + 1
ReDim Preserve TabFin(1 To 8, 1 To x)
For k = 1 To 8
TabFin(k, x) = Tablo(j, k)
Next
End If
Next
Next
FC.Range("A1").Resize(UBound(TabFin, 2), UBound(TabFin, 1)) = Application.Transpose(TabFin)
FC.Columns("E:E").NumberFormat = "m/d/yyyy" ' mise au format date
FS.Range("E2:E" & DerL).NumberFormat = "m/d/yyyy" ' remise au format date
Else
MsgBox "Aucun produit à date de péremption dans les 9 à 12 prochains mois"
End If
End Sub