Microsoft 365 Copier une ligne s'il y a une cellule en "ROUGE" dans celle-ci

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TS As ListObject 'déclare la variable TS (Tableau Source)
Dim TD As ListObject 'déclare la variable TD (Tableau Destination)
Dim I As Integer 'déclare la variable I (Incrément)
Dim R As Range 'déclare la variable R (Recherche)
Dim LI As Integer 'déclare la variable LI (LIgne)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set OS = Worksheets("Tableau de bord") 'définit l'onglet OS
Set OD = Worksheets("Synthèses") 'définit l'onglet OD
Set TS = OS.ListObjects("Tableau6") 'définit le tableau TS
Set TD = OD.ListObjects("Tableau4") 'définit le tableau TD
If TD.ListRows.Count > 0 Then TD.DataBodyRange.Delete 'efface les données de TD si TD contient au moins une ligne
For I = 1 To TS.ListRows.Count 'boucle sur toutes les lignes I de TS
    If TS.DataBodyRange(I, 8) <> "" Then 'condition 1 : si la valeur en colonne 8 n'est pas vide
        'condition 2 : reprend les deux conditions de la MFC,si une des condition est vérifiée
        If CDate(TS.DataBodyRange(I, 8)) < Date Or DateSerial(Year(CDate(TS.DataBodyRange(I, 8))), Month(CDate(TS.DataBodyRange(I, 8))) - 3, Day(CDate(TS.DataBodyRange(I, 8)))) < Date Then
            Set R = TD.ListColumns(1).Range.Find("") 'définit la recherche R (recherche du vide dans la colonne 1 de TD)
            If R Is Nothing Or TD.ListRows.Count = 0 Then 'condition 3 : si aucune occurrence n'est trouvée ou si TD ne contient aucune ligne
                TD.ListRows.Add 'ajoute une ligne à TD
                LI = TD.ListRows.Count 'définit la ligne LI (la dernière ligne de TD)
            Else 'sinon (au moins une occurrence est trouvée)
                LI = R.Row - TD.HeaderRowRange.Row + 1 'définit la ligne LI (ligne de la première occurence trouvée moins la ligne des en-têtes de TD plus une)
            End If 'fin de la condition 3
            TS.ListRows(I).Range.Copy 'copie la ligne I de TS
            TD.DataBodyRange(LI, 1).PasteSpecial (xlValues) 'colle les valeurs dans les données de TD ligne LI colonne 1
            'récupère le nom et prénom (parfois non renseigné en colonne 1 de TS)
            TD.DataBodyRange(LI, 1) = IIf(TS.DataBodyRange(I, 1) <> "", TS.DataBodyRange(I, 1).Value, TS.DataBodyRange(I, 1).End(xlUp).Value)
            'récupère la matricule (parfois non renseignée en colonne 2 de TS)
            TD.DataBodyRange(LI, 2) = IIf(TS.DataBodyRange(I, 2) <> "", TS.DataBodyRange(I, 2).Value, TS.DataBodyRange(I, 1).End(xlUp).Offset(0, 1).Value)
        End If 'fin de la condition 2
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle
Application.CutCopyMode = False 'suprimme le clignotement lié au copier/coller
OD.Activate 'active l'onglet OD
OD.Range("C14").Select 'sélectionne la cellule C14 de OD
End Sub

Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
Range("C16:J" & Rows.Count).Delete xlUp
With Sheets("Tableau de bord").ListObjects(1).Range
    On Error Resume Next 'si aucune SpecialCell
    Set r = .Columns(1).Resize(, 2).SpecialCells(xlCellTypeBlanks)
    r = "=R[-1]C" 'remplit les cellules vides avec la valeur au-dessus
    .Cells(2, 10) = "=(J16<>"""")*((J16<TODAY())+(J16<EDATE(TODAY(),3)))" 'critère
    .AdvancedFilter xlFilterCopy, .Cells(1, 10).Resize(2), [C15:J15] 'filtre avancé copié
    .Cells(2, 10) = ""
    r = ""
End With
End Sub

Private Sub Worksheet_Activate()
Dim r As Range
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Range("C16:J" & Rows.Count).Delete xlUp
With Sheets("Tableau de bord").ListObjects(1).Range
    On Error Resume Next 'si aucune SpecialCell
    Set r = .Columns(1).Resize(, 2).SpecialCells(xlCellTypeBlanks)
    r = "=R[-1]C" 'remplit les cellules vides avec la valeur au-dessus
    .Cells(2, 10) = "=(J16<>"""")*((J16<TODAY())+(J16<EDATE(TODAY(),3)))" 'critère
    .AdvancedFilter xlFilterCopy, .Cells(1, 10).Resize(2), [C15:J15] 'filtre avancé copié
    .Cells(2, 10) = ""
    r = ""
    '---copie la MFC---
    If [J16] = "" Then Exit Sub
    Set r = ActiveCell
    .Cells(2, 8).Copy
    Range("J16", Range("J" & Rows.Count).End(xlUp)).PasteSpecial xlPasteFormats 'collage spécial Formats
    Application.CutCopyMode = 0
    r.Select
End With
End Sub