Copier-coller des infos d'une feuille vers d'autres feuilles selon un critère

Sub EclaterClasseurs_BIS()
'archive :JM | 2013
'auteur macro d'origine: JoeMo - avril 2013
Dim lR&, vA As Variant, d As Object, JT As Variant, Wsht As Worksheet
Set Wsht = Sheets("base")
If Wsht.AutoFilterMode Then Wsht.Range("A1").AutoFilter
lR = Wsht.Range("A" & Rows.Count).End(xlUp).Row
vA = Wsht.Range("A2", "P" & lR).Value
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
For i = LBound(vA, 1) To UBound(vA, 1)
    If Not d.exists(vA(i, 1)) Then d.Add vA(i, 1), i
Next i
JT = d.keys
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = LBound(JT) To UBound(JT)
    On Error Resume Next
    Sheets(JT(i)).Delete
    On Error GoTo 0
    With Wsht
        .Range("A1").AutoFilter field:=1, Criteria1:=JT(i)
        .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = JT(i)
        With ActiveSheet.Range("A1")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            Wsht.Select
        End With
    End With
Next i
If Wsht.AutoFilterMode Then Wsht.Range("A1").AutoFilter
Application.DisplayAlerts = True
End Sub

Sub mEclater()
'*archive :JM |=>MX|a-poulsom|101011V38|kw:split/w*
Dim WSt As Worksheet, Plg As Range, c As Range, nFeuilles As New Collection, ws
Application.ScreenUpdating = False
mClean
Set WSt = Worksheets("base") 'adapter avec le nom de la feuille idoine
Set Plg = WSt.Range("A2", WSt.Cells(Rows.Count, 1).End(3))
On Error Resume Next
For Each c In Plg
    nFeuilles.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Plg = WSt.Range("A1:P" & WSt.Cells(Rows.Count, 1).End(3).Row) 'adapter la référence de la plage
For Each ws In nFeuilles
    With Sheets.Add(after:=Worksheets(Worksheets.Count))
    .Name = ws: Plg.AutoFilter 1, ws
    Plg.SpecialCells(12).Copy .Range("A1"): Plg.AutoFilter
    End With
Next ws
WSt.Activate
Application.ScreenUpdating = True
End Sub
Private Sub mClean()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If Not ws.Name Like "base" Then
ws.Delete
End If
Next
End Sub