Sub tata()
Dim i&, l&, nChp&, calcEtat&, lstFl(), dicFl As New Dictionary, tmp As Range, plgChp As Range, aFl As Worksheet, pFl As Worksheet
With Sheets("Achats")
With .Range("A1")
Set plgChp = .Parent.Range(.Cells, .Parent.Cells(.Row, .Parent.Columns.Count).End(xlToLeft))
For nChp = 1 To plgChp.Count
If LCase(plgChp(nChp).Value) = "marque" Then Exit For
Next
End With
If nChp <= plgChp.Count Then
Set tmp = .Range(plgChp(nChp), .Cells(.Rows.Count, plgChp(nChp).Column).End(xlUp))
For i = 2 To tmp.Count
If Not dicFl.Exists(CStr(tmp(i).Value)) Then dicFl.Add CStr(tmp(i).Value), 1
Next
If dicFl.Count > 0 Then
lstFl = dicFl.Keys
Set dicFl = Nothing
With Application: .ScreenUpdating = 0: calcEtat = .Calculation: .Calculation = -4135: .EnableEvents = 0: End With
Set pFl = ActiveSheet
With plgChp.Resize(tmp.Count, plgChp.Count)
For i = 0 To UBound(lstFl)
On Error Resume Next
Set aFl = Sheets(lstFl(i))
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lstFl(i)
l = 0
Else
aFl.Activate
l = aFl.Cells(aFl.Rows.Count, 1).End(xlUp).Row + IsEmpty(aFl.[A1])
End If
.AutoFilter Field:=nChp, Criteria1:=lstFl(i)
.Copy Destination:=ActiveSheet.[A1].Offset(l)
With ActiveSheet
.Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp).Offset(0, plgChp.Count - 1)).RemoveDuplicates _
Columns:=Array(1, 2, 3, 4, 5), Header:=xlNo
.Move After:=Sheets(ThisWorkbook.Sheets.Count)
End With
Next
End With
plgChp.AutoFilter
pFl.Activate
With Application: .EnableEvents = 1: .Calculation = calcEtat: .ScreenUpdating = 1: End With
End If
End If
End With
End Sub
