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)