J'ai des lignes de différentes couleurs - Comment regrouper les lignes ayant la même couleur ?

Catte fonctionnalité est maintenant intégrée dans excel 2007.

sub TriParCouleurs()  
'trie une plage de données soit sur la couleur d'une de ses cellules  
'soit en regroupant ses lignes par couleurs 
 Dim cell As Range, Col1%, derCol%, Li1&, derLi&, couleur&, Msg$, choix% 
 Dim plage As Range   
 Msg = "Pour trier sur une couleur, cliquez sur ""Oui""" & vbLf  
Msg = Msg & "Pour trier sur toutes les couleurs, cliquez sur  ""Non""" & vbLf 
 Msg = Msg & "Pour abandonner, cliquez sur ""Annuler"""    
choix = MsgBox(Msg, vbYesNoCancel)  
Select Case choix  
 Case 2: exit sub   
Case 6: Gosub SelectCell: Gosub SelectPlage   
Case 7: Gosub SelectPlage
 End Select
 
 Li1 = plage.Range("A1").Row
 Col1 = plage.Range("A1").Column
 derLi = Li1 + plage.Rows.Count - 1
 derCol = Col1 + plage.Columns.Count
 
 Application.ScreenUpdating = False
 Columns(derCol).Insert Shift:=xlToRight
 Select Case choix
  Case 6
   couleur = cell.Interior.ColorIndex
   For i = Li1 To derLi
    If Cells(i, Col1).Interior.ColorIndex = couleur Then
     Cells(i, derCol).Value = couleur
     If Application.CountA(Cells(i, Col1), Cells(i, derCol - 1)) = 0 Then
      Cells(i, derCol).Value = couleur + 1
     End If
    End If
   Next
  Case 7
   For i = Li1 To derLi
    couleur = Cells(i, Col1).Interior.ColorIndex
    If couleur < 0 Then couleur = couleur * -1
    Cells(i, derCol).Value = couleur
    If Application.CountA(Cells(i, Col1), Cells(i, derCol - 1)) = 0 Then
      Cells(i, derCol).Value = couleur + 1
    End If
   Next
 End Select
 
 Range(Cells(Li1, Col1), Cells(derLi, derCol)).Sort _
        Cells(Li1, derCol), xlAscending
 Columns(derCol).Delete Shift:=xlToLeft
 exit sub
 
 SelectCell:
 
 Msg = vbLf & "Sélectionner une cellule de la couleur à trier :"
 On Error Resume Next
 Application.DisplayAlerts = False
 Set cell = Application.InputBox(Msg, , , , , , , 8)
 Application.DisplayAlerts = True
 If Err <> 0 Then
  Err.Clear: exit sub
 End If
 
 If cell.Count > 1 Then
  MsgBox "Sélectionnez une seule cellule, SVP"
  TriParCouleurs
 End If
 Return
 
 SelectPlage:
 
 Msg = "Sélectionnez la plage des données à trier"
 On Error Resume Next
 Application.DisplayAlerts = False
 Set plage = Application.InputBox(Msg, , , , , , , 8)
 Application.DisplayAlerts = True
 If Err <> 0 Then
  Err.Clear: exit sub
 End If
 
 If plage.Rows.Count = 1 Then
  MsgBox "La plage à trier doit comporter au moins 2 lignes..."
  TriParCouleurs
 End If
 Return
 
 end sub