Extraction dans onglet différent selon couleur

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, b, i, code, c As Range
a = Array("Jaune", "Vert", "Rouge", "Incolore")
b = Array(6, 10, 3, xlNone)
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
code = b(i - 1)
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
Feuil1.UsedRange.Copy Sh.[A1] 'Feuil1 CodeName à adapter
For i = Sh.UsedRange.Rows.Count To 1 Step -1
  Set c = Sh.Cells(i, 2)
  If IsNumeric(CStr(c)) And c.Interior.ColorIndex <> code _
    Then c.EntireRow.Delete
Next
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, b, i, code, c As Range, sup As Boolean, flag As Boolean
a = Array("Jaune", "Vert", "Rouge", "Incolore")
b = Array(6, 10, 3, xlNone)
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
code = b(i - 1)
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
Feuil1.UsedRange.Copy Sh.[A1] 'Feuil1 CodeName à adapter
For i = Sh.UsedRange.Rows.Count To 2 Step -1
  Set c = Sh.Cells(i, 2)
  If IsNumeric(CStr(c)) Then
    If c.Interior.ColorIndex = code Then _
      flag = True Else sup = True
  Else
    If Not flag And (c(1, 0) Like "Sous*" Or _
      c(0, 0) Like "Sous*") Then sup = True
    If c(1, 0) Like "Sous*" Then flag = False
  End If
  If sup Then c.EntireRow.Delete: sup = False
Next
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, b, i, code, c As Range, flag As Boolean, sup As Range
a = Array("Jaune", "Vert", "Rouge", "Incolore")
b = Array(6, 10, 3, xlNone)
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
code = b(i - 1)
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
Feuil1.UsedRange.EntireRow.Copy Sh.[A1] 'Feuil1 CodeName à adapter
For i = Sh.UsedRange.Rows.Count To 2 Step -1
  Set c = Sh.Cells(i, 2)
  If IsNumeric(CStr(c)) Then
    If c.Interior.ColorIndex = code Then _
      flag = True Else Set sup = Union(c, IIf(sup Is Nothing, c, sup))
  Else
    If Not flag And (c(1, 0) Like "Sous*" Or c(0, 0) Like "Sous*") _
      Then Set sup = Union(c, IIf(sup Is Nothing, c, sup))
    If c(1, 0) Like "Sous*" Then flag = False
  End If
Next
If Not sup Is Nothing Then sup.EntireRow.Delete
End Sub