[Résolu]Regroupement données

Option Explicit

Sub Report_Key()
Dim Sh As Worksheet
Dim Cel As Range
Dim DerLig As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each Sh In Sheets
    If Sh.Name <> "Carac" And Sh.Name <> "Modele" Then
        Sh.Delete
    End If
Next Sh
With Sheets("Carac")
    DerLig = .[A65000].End(xlUp).Row
    .Range("A1:J" & DerLig).Name = "Base"
    .[Z1] = .[A1]
    .Range("A1:A" & DerLig).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("Z1"), Unique:=True
    For Each Cel In .Range("Z2:Z" & .[Z65000].End(xlUp).Row)
        If Cel.Value <> "" Then
            .[Z2] = Cel.Value
            Sheets("Modele").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Cel.Value
            .Range("Base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), _
                CopyToRange:=Range("A1:J1"), Unique:=False
            ActiveSheet.Cells.EntireColumn.AutoFit
        End If
    Next Cel
    .Columns(26).Clear
    .Select
End With
Sheets("Carac").[A1].Select
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With
End Sub

Option Explicit
Dim DocDép, k, NomClasse, Onglet

Sub UneClasseParOnglet()
 Call Macro_tri
 
Application.ScreenUpdating = False
Set DocDép = ActiveSheet
'
    
   ' Initialisation : On supprime les onglets de classe éventuellement existant
    For Each Onglet In Worksheets
    Application.DisplayAlerts = False
    If Onglet.Name <> "carac" Then
        Sheets(Onglet.Name).Activate
        ActiveWindow.SelectedSheets.Delete
    End If
    Next Onglet

   
   'Routine qui recrée les onglets
   k = 0
   While Worksheets("carac").Cells(2 + k, 1).Value <> ""
        If Worksheets("carac").Cells(2 + k, 1).Value <> Worksheets("carac").Cells(1 + k, 1).Value Then '
            NomClasse = Sheets("carac").Cells(2 + k, 1).Value
            Sheets.Add After:=Sheets(Sheets.Count) 'On ouvre un nouvel onglet
            ActiveSheet.Name = NomClasse 'on renomme l'onglet
            Application.StatusBar = NomClasse
            Sheets("carac").Rows(1).Copy Cells(1, 1)
        End If
        Sheets(NomClasse).Activate
        'Sheets(NomClasse).Cells(Cells(65000, 1).End(xlUp).Row + 1, 1).Select
        Worksheets("carac").Rows(2 + k).Copy Worksheets(NomClasse).Cells(Cells(65000, 1).End(xlUp).Row + 1, 1)
        DocDép.Activate
    
        k = k + 1
   Wend
   Application.StatusBar = ""
   Beep
    
End Sub