Trier les lignes par couleurs

[Mikado]

Bonjour,

Est-il possible (macro ?) de faire un tri de ligne par couleurs (les lignes de mon donc excel sont déjà en couleurs et je souhaites les trier ensuite).

Merci B)

 

[dg62]

Bonjour Mikado

Macro de F Sigonneau

 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 

 Frédéric Sigonneau,  (N°1036)