Sub Production_Schedule()
Dim F As Worksheet, t, d As Object, i&, liste, chemin$
Dim e, critere$, tf, ncol%, n&, txt$, j%
Set F = Feuil1 'CodeName de la feuille
'---liste des partenaires sans doublon---
t = F.ListObjects(1).DataBodyRange 'matrice
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
If t(i, 8) <> "" Then d(t(i, 8)) = ""
Next i
If d.Count = 0 Then Exit Sub
liste = d.keys
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier existe déjà
chemin = ThisWorkbook.Path & "\" 'à adapter
For Each e In liste
critere = UCase(e) 'majuscules
With Workbooks.Add.Sheets(1) 'nouveau document
F.ListObjects(1).Range.Copy .[A1]
.[A1].Copy .[A1] 'vide la mémoire
.ListObjects(1).Range.Columns("AG:AH").Delete
.ListObjects(1).Range.Columns("A:C").Delete
With .ListObjects(1).DataBodyRange
t = .Value 'matrice des valeurs, plus rapide
tf = .FormulaR1C1 'matrice des formules
ncol = UBound(t, 2)
d.RemoveAll 'RAZ
n = 0
For i = 1 To UBound(t)
If UCase(t(i, 5)) = critere Then
txt = ""
For j = 1 To ncol
txt = txt & Chr(1) & t(i, j)
Next j
If Not d.exists(txt) Then 'pour éliminer les lignes doublons
d(txt) = ""
n = n + 1
For j = 1 To ncol
t(n, j) = tf(i, j)
Next j
t(n, 5) = critere 'facultatif, nom du partenaire en majuscules
End If
End If
Next i
If n Then .Resize(n).FormulaR1C1 = t 'restitution
If n < .Rows.Count Then .Rows(n + 1 & ":" & .Rows.Count).Delete
End With
.Columns.AutoFit 'ajustement de la largeur
.Columns("C:D").Hidden = True
critere = Replace(Replace(Replace(Replace(Replace(critere, "/", "_"), "&", "_"), "...", "_"), ".", "_"), " ", "_")
critere = chemin & "fichier_partenaire_" & critere & "_" & Format(Date, "d-mm-yy")
.Parent.SaveAs critere, FileFormat:=51 'fichier .xlsx
.Parent.Close
End With
Next e
End Sub