[VBA - Résolu] Faire un copier coller avec un critère

Sub copier_coller()
Dim O As Object 'déclare la variable O (Onglet)
Dim DL As Byte 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim OD As Object 'déclare la variable OD (Onglet de Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("BDD eleves") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet O
Set PL = O.Range("A3:A" & DL) 'définit la plage PL
For Each CEL In PL 'boucle sur toutes les cellules CEl de la plage PL
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Sheets(CEL.Offset(0, 4).Value) 'définit l'onglet de destination OD (génère une erreur si c'est onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'efface l'erreur
        With Sheets("classement eleves") 'prend en compte l'onglet "classement eleves"
            .Visible = True 'affiche l'onglet
            .Copy AFTER:=Sheets(Sheets.Count) 'copy l'onglet en dernière position
            ActiveSheet.Name = CEL.Offset(0, 4).Value 'renomme l'onglet
            Set OD = ActiveSheet 'définit l'onglet de destination OD
            .Visible = False 'masque l'onglet "classement eleves"
        End With 'fin de la prise en compte de l'onglet "classement eleves"
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
    CEL.Resize(1, 7).Copy DEST 'colie la plage A:G de CEL et la colle dans DEST
    CEL.Offset(0, 7).Copy DEST.Offset(0, 9) 'copie la plage H de CEl et la colle dans la colonne J de DEST
    CEL.Offset(0, 8).Copy DEST.Offset(0, 11) 'copie la plage I de CEl et la colle dans la colonne L de DEST
    CEL.Offset(0, 9).Copy DEST.Offset(0, 14) 'copie la plage J de CEl et la colle dans la colonne O de DEST
Next CEL 'prochaine cellule de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

    'cacul des points TOEFL
    Set OP = Sheets("Pondération") 'définit l'onglet OP
    DLM = OP.Cells(Application.Rows.Count, 3).End(xlUp).Row 'définit la dernière ligne étidée DLM de la colonne 3 (=C) de l'onglet OP
    For LI = DLM To 4 Step -1 'boucle inversée sur les cellules du "score max" de l'onglet "Pondération" de la dernière à la première
        'si la cellule en colonne H de CEL (TOEFL) est inférieure à la cellule de la boucle,
        'récupère les points en colonne D, sort de la boucle
        If CEL.Offset(0, 7) < OP.Cells(LI, 3) Then DEST.Offset(0, 10).Value = OP.Cells(LI, 4).Value: Exit For
    Next LI 'prochaine cellule de la boucle inversée

Sub copier_coller()
Dim O As Object 'déclare la variable O (Onglet)
Dim DL As Integer 'déclare la variable DL (Dernière Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim OD As Object 'déclare la variable OD (Onglet de Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim LiC As Integer 'déclare la variable LiC (Ligne de la cellule Cel)
Dim LiD As Integer 'déclare la variable LiD (Ligne de la cellule de Destination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("BDD eleves") 'définit l'onglet O
DL = O.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet O
Set PL = O.Range("A3:A" & DL) 'définit la plage PL
For Each CEL In PL 'boucle sur toutes les cellules CEl de la plage PL
    LiC = CEL.Row 'définit la ligne LiC de la cellule CEL
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set OD = Sheets(CEL.Offset(0, 4).Value) 'définit l'onglet de destination OD (génère une erreur si c'est onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'efface l'erreur
        With Sheets("classement eleves") 'prend en compte l'onglet "classement eleves"
            .Visible = True 'affiche l'onglet
            .Copy AFTER:=Sheets(Sheets.Count) 'copy l'onglet en dernière position
            ActiveSheet.Name = CEL.Offset(0, 4).Value 'renomme l'onglet
            Set OD = ActiveSheet 'définit l'onglet de destination OD
            .Visible = False 'masque l'onglet "classement eleves"
        End With 'fin de la prise en compte de l'onglet "classement eleves"
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    LiD = OD.Cells(Application.Rows.Count, 1).End(xlUp).Row + 1 'définit Ligne LiD de la cellule de destination DEST
    O.Range(O.Range("A" & LiC), O.Range("J" & LiC)).Copy OD.Range("A" & LiD)
    O.Range("K" & LiC).Copy OD.Range("M" & LiD) 'copie la plage K de CEl et la colle dans la colonne M de DEST
    O.Range("L" & LiC).Copy OD.Range("O" & LiD) 'copie la plage K de CEl et la colle dans la colonne M de DEST
    O.Range("M" & LiC).Copy OD.Range("R" & LiD) 'copie la plage K de CEl et la colle dans la colonne M de DEST
Next CEL 'prochaine cellule de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub