Option Explicit
Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Dico As Dictionary, cel As Range, connue As Worksheet, Tablo, Tablo1()
Dim i As Long, k As Long, x As Long, NouvelleFeuille As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dico = New Dictionary
'Suppression de toutes les feuilles sauf la 1ère
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
'Boucle sur toutes les lignes remplies de la colonne A - A partir de A2
With Feuil1
For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
'Mise en mémoire des noms des onglets à créer
If Not Dico.Exists(cel.Value) Then Dico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
Next cel
Tablo = .Range("A2:M" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
'Boucle sur toutes les noms en mémoire et création de la feuille
For i = 0 To Dico.Count - 1
For k = LBound(Tablo, 1) To UBound(Tablo, 1)
If Tablo(k, 1) = Dico.Keys(i) Then
x = x + 1
ReDim Preserve Tablo1(1 To 10, 1 To x)
Tablo1(1, x) = Tablo(k, 4)
Tablo1(2, x) = Tablo(k, 5)
Tablo1(3, x) = Tablo(k, 6)
Tablo1(4, x) = Tablo(k, 7)
Tablo1(5, x) = Tablo(k, 8)
Tablo1(6, x) = Tablo(k, 9)
Tablo1(7, x) = Tablo(k, 10)
Tablo1(8, x) = Tablo(k, 11)
Tablo1(9, x) = Tablo(k, 12)
Tablo1(10, x) = Tablo(k, 13)
End If
Next k
NouvelleFeuille = Dico.Items(i)(0)
On Error Resume Next
Set connue = Sheets(NouvelleFeuille)
If Err <> 0 Then Sheets.Add.Name = NouvelleFeuille
On Error GoTo 0
'Avec la feuille créée
With Sheets(NouvelleFeuille)
'On copie les intitulés
.Cells(2, 1).Value = Dico.Items(i)(1)
.Cells(3, 1).Value = Dico.Items(i)(2)
.Cells(5, 1).Value = Dico.Items(i)(0)
.Cells(6, 1).Resize(1, 10) = Array("N° Item", "N° Cas Type", "Date", _
"Code Mesure", "Poids", "Résultat corrigé", "Résultat", "Minimum", _
"Maximum", "Code unité")
.Cells(6, 1).Resize(1, 10).Interior.ColorIndex = 43
'On complète le tableau avec les données correspondantes à chacun
.Cells(7, 1).Resize(UBound(Tablo1, 2), UBound(Tablo1, 1)) = Application.Transpose(Tablo1)
End With
Erase Tablo1: x = 0
'On passe à la feuille suivante
Next i
Sheets("Données").Move Sheets(1)
Sheets("Données").Select
Set Dico = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub