Sub Copie()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim P As Range, nlig As Long, col As Integer, lig As Long, n As Long
Set P = Feuil1.UsedRange 'source
nlig = P.Rows.Count
Application.ScreenUpdating = False 'fige l'écran
Feuil2.Rows("2:" & Rows.Count).Delete 'RAZ
n = 2 '1ère ligne de destination
For col = 1 To P.Columns.Count
For lig = 1 To nlig
If P(lig, col).Interior.ColorIndex <> xlNone Then
P(lig, col).Copy
With Feuil2.Cells(n, 1)
.PasteSpecial xlPasteFormats
.Value = P(lig, col)
End With
n = n + 1 'ligne suivante
End If
Next
Next
Application.Goto Feuil2.[A1], True
Feuil2.Columns(1).AutoFit 'ajustement largeur
End Sub