Copier Coller une ligne si une cellule est surligner en rouge

Const coul1 = 15
Const coul2 = xlNone
Const codeb = 1
Const coreg = 3
Const coite = 4
Const copre = 6
Const cocam = 7
Const corec = 8
Const coext = 9
Const copro = 10
Const comac = 11
Const lideb = 2
Const rouge = 3
Const vert = 50

Public Sub ok()
Dim li As Long, lifin As Long, coul As Long
Dim reg As String, li1 As Long, li2 As Long, ok As Boolean
Dim cofin As Long, co As Long, s As Long, plage As Range, cel As Range, lc As String
Dim mac As Long, ite As String
Dim obj As Object, liobj As Long
lifin = Cells(Rows.Count, coreg).End(xlUp).Row
cofin = Cells(1, Columns.Count).End(xlToLeft).Column
Set plage = Range(Cells(lideb, codeb), Cells(lifin, cofin))
plage.Interior.ColorIndex = xlNone
plage.Interior.ColorIndex = xlAutomatic
Application.ScreenUpdating = False
coul = coul1
Range(Cells(lideb, codeb), Cells(lideb, cofin)).Interior.ColorIndex = coul
' alternance coul1 - coul2
For li = lideb + 1 To lifin
  Range(Cells(li, codeb), Cells(li, cofin)).Interior.ColorIndex = coul
  If Cells(li, coreg).Value <> Cells(li + 1, coreg) Then coul = coul1 + coul2 - coul
Next li
' les surlignements rouges
li1 = lideb
Do
  reg = Cells(li1, coreg).Value
  ok = True
  lc = ""
  li2 = li1
  While Cells(li2, coreg).Value = reg And li2 <= lifin
    Set plage = Range(Cells(li2, copre), Cells(li2, copro))
    s = Application.WorksheetFunction.Sum(plage)
    If s <> 1 Then ok = False
    If ok Then
      For Each cel In plage
        If cel.Value <> "" Then
          co = cel.Column
          If co = corec Or co = coext Then co = corec
          If InStr(1, lc, co - 1) = 0 Then lc = lc & co - 1
        End If
      Next cel
      If Len(lc) > 1 Then ok = False
    End If
    li2 = li2 + 1
  Wend
suite:
  If Not ok Then Range(Cells(li1, codeb + 1), Cells(li2 - 1, cofin)).Interior.ColorIndex = rouge
  If Not ok Then Range(Cells(li1, codeb + 1), Cells(li2 - 1, cofin)).Select
  Selection.Copy
  Sheets("Feuil3").Select
  Range("A1").Select
  ActiveSheet.Paste
  li1 = li2
Loop Until li2 > lifin
' les surlignements verts
li1 = lideb
Do
  reg = Cells(li1, coreg).Value
  If Cells(li1, copro) = 1 Then
    ite = Cells(li1, coite).Value
    mac = Cells(li1, comac).Value
    Set plage = Range(Cells(li1, coite), Cells(lifin, coite))
    Set obj = plage.Find(ite, , , xlWhole)
    If Not obj Is Nothing Then
      liobj = obj.Row
      If Cells(liobj, copre).Value = 1 And Cells(liobj, comac).Value = mac + 1 Then
        Set plage = Range(Cells(li1, codeb), Cells(li1, cofin))
        plage.Font.ColorIndex = vert
        Set plage = Range(Cells(liobj, codeb), Cells(liobj, cofin))
        plage.Font.ColorIndex = vert
      End If
    End If
  End If
  li1 = li1 + 1
Loop Until li1 >= lifin
End Sub