'le code de cette fonction doit toujours être placé dans un module standard
Function Rouge(c As Range) As Boolean
Rouge = c.Font.ColorIndex = 3
End Function
Sub DepLigneCouleur()
Dim dest As Range 'déclare la variable dest (DESTination)
Dim n As Long 'déclare la variable n
Application.ScreenUpdating = False 'masque les changements à l'écran
Set dest = Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp)(2)
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
With .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) '1ère colonne
If .Row = 1 Then Exit Sub
.Columns(8) = "=1/Rouge(A2)" 'formule utilisant la fonction en colonne auxiliaire H
.Columns(8) = .Columns(8).Value 'supprime les formules
.EntireRow.Sort .Columns(8), xlDescending, Header:=xlNo 'tri pour regrouper et accélérer
n = Application.Count(.Columns(8))
If n Then
With .Columns(8).SpecialCells(xlCellTypeConstants, 1).EntireRow
.Resize(, 7).Copy dest 'copie les colonnes A:G
.Delete
End With
dest(1, 2).Resize(n, 2).Validation.Delete 'supprime les listes de validation en colonnes B et C
dest(1, 7).Resize(n) = dest(1, 7).Resize(n).Value 'supprime les formules en colonne G
End If
.Columns(8).ClearContents 'RAZ de la colonne H auxiliaire
End With
End With
dest.Parent.Cells.Sort dest.Parent.Cells(1), xlAscending, Header:=xlYes 'tri de la 2ème feuille
Application.Goto dest.Parent.Range("A1")
Application.Goto Sheets("Feuil1").Range("B1")
End Sub