Discussion :

[will Igetit]

je soujaiterais qu ma ligne 1 bleu descende jusqua ce quell ne trouve plus de ligne rouge en desous.
eplication L1: ligne1 bleu
L2: ligne 2 rouge
L3: ligne 3 rouge
L4: ligne 4 bleu

je souhaiterai obtenir
L3: ligne1 bleu
L1: ligne 2 rouge
L2: ligne 3 rouge
L3: ligne1 bleu
L4: ligne 4 bleu

quelquun serait il faire cela?

[Jean-Philippe André]

salut,
tu peux utiliser le principe de "tri à bulles" avec non pas la valeur de ta cellule, mais la couleur de celle-ci.

[ouskel'n'or]

salut,
tu peux utiliser le principe de "tri à bulles" avec non pas la valeur de ta cellule, mais la couleur de celle-ci.

Hello jpcheck, je ne connais pas. Cela fonctionne-t-il sur Excel 2003 ?
J'avais ça, non pour un tri par couleur mais pour déplacer les lignes d'une couleur précise après la dernière ligne d'une autre couleur donnée.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Option Explicit
Sub Appel()
Dim i As Long, Derlig As Long, Couleur As Integer, RedLine As Long, LinCur As Long
    Derlig = Split(Worksheets("Feuil1").UsedRange.Address, "$")(4)
    Couleur = 3
    'Recherche de la dernière ligne rouge
    RedLine = LinRed(Couleur, Derlig)
    'Le premier déplacement se fera sous la dernière ligne rouge
    LinCur = RedLine + 1
    For i = Derlig To 1 Step -1
        If Cells(i, 1).Font.ColorIndex = 5 And i < RedLine Then
            Rows(i).EntireRow.Cut
            Rows(LinCur & ":" & LinCur).Insert Shift:=xlUp
            'La ligne suivante doit être insérée après la dernière ligne insérée
            LinCur = RedLine
            'La ligne insérée déplace la ligne rouge vers le haut
            RedLine = RedLine - 1
        End If
    Next
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
'Recherche de la dernière ligne rouge
Function LinRed(Couleur As Integer, Derlig As Long)
Dim i As Long
    For i = Derlig To 1 Step -1
        If Cells(i, 1).Font.ColorIndex = 3 Then
            LinRed = i
            Exit Function
        End If
    Next
End Function

Conserve l'ordre des données déplacées
A défaut de connaître "aut' chose"

[will Igetit]

en fait ne sacchant pas comment faire , j'ai trouver une astuce pour tricher un peu.
lorsque j'ai atribue une couleur a une ligne j'attribue un chiffre sur une collone vide de cette ligne et par la suuite j'ai trie ma plage sur e cette colonne.
voici le code complet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Private Sub CommandButton1_Click()
 
'Rows(1).Delete
Dim DerCel As Long
DerCel = Worksheets("Sheet1").Range("B65536").End(xlUp).Row
Rows(DerCel + 1).Interior.Color = RGB(0, 0, 0)
 
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
 
Application.ScreenUpdating = False
 
For i = 1 To DerCel
 
If Cells(i, 5).Value < 0 Then
For j = 1 To 9
Cells(i, j).Interior.Color = RGB(250, 0, 0)
Next j
Cells(i, 10).Value = 1
ElseIf Cells(i, 6).Value < 0 Then
For k = 1 To 9
Rows(i).Columns(k).Interior.Color = RGB(200, 100, 100)
Next k
Cells(i, 10).Value = 2
ElseIf Cells(i, 7).Value < 0 Then
For l = 1 To 9
Rows(i).Columns(l).Interior.Color = RGB(0, 250, 250)
Next l
Cells(i, 10).Value = 3
ElseIf Cells(i, 8).Value < 0 Then
For l = 1 To 9
Rows(i).Columns(l).Interior.Color = RGB(120, 120, 120)
Next l
Cells(i, 10).Value = 4
ElseIf Rows(i).Interior.Color = RGB(0, 0, 0) Then Exit Sub
Else: Rows(i).EntireRow.Delete
i = i - 1
DerCel = DerCel - 1
 
End If
 
Next i
Application.ScreenUpdating = True
 
Range("A1:J65535").Select
Selection.Sort Key1:=Range("J1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    Range("J:J").Delete