'NOMMER LA FEUILLE D'ORIGINE "Données"
'LA LISTE COMMENCE EN A2
Sub Balaye()
Dim NoDupes As New Collection
'Application.ScreenUpdating = False
A = Range([A2], [A65536].End(xlUp)).Value
On Error Resume Next
' Boucle pour récupérer la collection d'items uniques
For J = 1 To UBound(A, 1)
NoDupes.Add A(J, 1), CStr(A(J, 1))
Next J
' Réactivation du gestionnaire d'erreurs
On Error GoTo 0
Range("A1").CurrentRegion.Select
With Selection.CurrentRegion
Intersect(.Cells, .Offset(1)).Select
End With
B = Selection.Value
NbCol = Selection.Columns.Count
[A1].Select
ReDim Tableau(1 To UBound(B), 1 To NbCol)
For k = 1 To UBound(B, 1)
For Z = 1 To NbCol
Tableau(k, Z) = B(k, Z)
Next Z
Next k
H = 1
For I = 1 To NoDupes.Count
Sheets.Add after:=Sheets(I)
ActiveSheet.Name = NoDupes(I)
For x = 1 To UBound(A, 1)
If Tableau(x, 1) = NoDupes(I) Then
For w = 1 To NbCol
Cells(H + 1, w).Value = Tableau(x, w)
Next w
H = H + 1
Else
End If
Next x
H = 1
Next I
Sheets("Données").Activate
NbSheet = ActiveWorkbook.Sheets.Count
Range([A1], [IV1].End(xlToLeft)).Select
Set MaPlage = Selection
[A1].Select
For NS = 2 To NbSheet
Set Destination = ActiveWorkbook.Sheets(NS).Range("A1")
MaPlage.Copy Destination
Next NS
'Application.ScreenUpdating = True
End Sub