Option Explicit
Sub Dispatche()
Dim Lg As Long
Dim I As Integer
Dim Cel As Range
Dim MonDico As Object
Dim Tablo()
Application.ScreenUpdating = False
Set MonDico = CreateObject("Scripting.Dictionary")
With Sheets("V15")
Lg = .Range("AD" & Rows.Count).End(xlUp).Row
For Each Cel In .Range("AD11:AD" & Lg)
If Cel <> "" Then MonDico(Cel.Value) = Cel.Value
Next Cel
Tablo = MonDico.items
For I = 0 To UBound(Tablo)
.Range("H11:H" & Lg).AutoFilter Field:=2, Criteria1:=Tablo(I), VisibleDropDown:=False
On Error Resume Next
Sheets(Tablo(I)).Select
If Err.Number > 0 Then
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Tablo(I)
End If
On Error GoTo 0
.Range("H4:H" & Lg).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(Tablo(I)).Range("A6")
Next I
.AutoFilterMode = False
.Select
End With
End Sub