XL 2016 Creation d´un onglet recapitulatif des notes par eleve

Option Explicit
Sub create_individual_fich()
   Dim I&, Nom$, C As Range, Sh As Worksheet
    Application.ScreenUpdating = False
    delete_all_afterQLM
    With Sheets("langage_oral_")
        For I = 6 To Cells(Rows.Count, "A").End(xlUp).Row

            If I <> 18 Then
                Set Sh = Sheets.Add(After:=Sheets(Sheets.Count))
                Nom = .Cells(I, 1)
                Sh.Name = Mid(.Cells(I, 1), 1, 30)
                .Range("A2:i4").Copy Destination:=Sh.Cells(1)
                .Cells(I, 1).Resize(, 9).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)

                '***********************************

                With Sheets("lecture_et_compréhension_de_l'é")
                    Set C = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Find(Nom, LookIn:=xlValues)
                    If Not C Is Nothing Then
                        .Range("A2:k4").Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                        C.Resize(, 11).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                    End If
                End With
                '***********************************
                With Sheets("écriture_")
                    Set C = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Find(Nom, LookIn:=xlValues)
                    If Not C Is Nothing Then
                        .Range("A1:H3").Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                        C.Resize(, 8).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                    End If
                End With
                '***********************************

                With Sheets("étude_de_la_langue_")
                    Set C = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Find(Nom, LookIn:=xlValues)
                    If Not C Is Nothing Then
                        .Range("A1:L3").Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                        C.Resize(, 12).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                    End If
                End With
                '***********************************
                With Sheets("Arts_visuels")
                    Set C = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Find(Nom, LookIn:=xlValues)
                    If Not C Is Nothing Then
                        .Range("A1:J4").Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                        C.Resize(, 10).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(5)
                    End If
                End With

                '***********************************
                With Sheets("Musique")
                    Set C = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Find(Nom, LookIn:=xlValues)
                    If Not C Is Nothing Then
                        .Range("A1:f4").Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                        C.Resize(, 6).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(4)
                    End If
                End With

                '***********************************
                With Sheets("QLM")
                    Set C = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Find(Nom, LookIn:=xlValues)
                    If Not C Is Nothing Then
                        .Range("A1:J3").Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                        C.Resize(, 10).Copy Destination:=Sh.Cells(Rows.Count, 1).End(xlUp).Offset(2)
                    End If
                End With
             
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub


Sub delete_all_afterQLM()
    Dim I&
    Application.DisplayAlerts = False
    For I = Sheets.Count To 8 Step -1
        If I > 7 Then Sheets(I).Delete
    Next
 
End Sub