Macro de tri première position

Version imprimable

Bonjour à tous,
Je me permet d'ouvrir une nouvelle discussion car mon problème est foncièrement différent.

Ma situation : J'ai X projets en cours, numérotés par classement d'importance (1 = urgent dernier= peu urgent) de 1 à 10.

Mon problème: Comme l'ordre d'urgence de mes projets est amené à changer, j'aimerai que lorsque je remonte ou baisse un projet dans mon classement, ce classement se mette à jour automatiquement, et que les positions se mettent à jour également.

Exemple: Sur mes 10 classés, le numéro 8 devient assez prioritaire et passe numéro 2. Je souhaite qu'il remonte dans ma liste, et que l'ancien n°2 passe N°3, l'ancien n°3 passe N°4, etc.

Mon code ressemble à cela pour le moment :
Code:

1 2 3 4 5 6 7 8 9 10 Sub Cacahuete() Dim Dligne as Integer Dligne = Range("A150").End(xlUp).Row Rows("45:" & Dligne).Sort Key1:=Range("A45"), Order1:=xlAscending, Key2:=Range("A45"), Order2:=xlAscending, Header:=no, OrderCustom:=1, MatchCase _ :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _ DataOption2:=xlSortNormal End Sub
Un premier problème se pose: Lorsque je modifie mon numéro d'importance (ex 8 à 2) celui-ci se classe APRES le précedent numéro 2 alors que je souhaiterai qu'il arrive avant.

Merci de votre aide,
Bonne journée,

26/03/2019, 14h12
Menhir

Le plus simple est de poser un filter sur tes données et tu pourras reclasser ta liste en deux clics.
Développer une macro pour ça semble peu rentable.
26/03/2019, 15h14
Mickamax

Bonjour, le problème reste le même puisque lorsque je trie grâce à un tableau il est possible d'avoir deux fois le même numéro (ex: deux ligne avec la prio 1).
Le calcul de priorisation ne se met pas à jour automatiquement, et il me faut donc reprendre 1 par 1 tous les projets suivants.

Bonne journée,
Mickamax

Bonjour le fil, bonjour le forum,

Une proposition... Pas terrible mais je n'ai pas mieux :
- Dans le composant VBA de l'onglet concerné :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Private V As Variant
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.Intersect(Target, Range("A45:A55")) Is Nothing Then Exit Sub
V = Target.Value
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Byte
Dim LI As Byte
 
If Application.Intersect(Target, Range("A45:A55")) Is Nothing Then Exit Sub
Application.EnableEvents = False
LI = Target.Row
For I = 45 To 55
    If I <> LI Then
        If Cells(I, "A") >= Target.Value Then Cells(I, "A").Value = Cells(I, "A").Value + 1
        If Cells(I, "A").Value > V Then Cells(I, "A").Value = Cells(I, "A").Value - 1
    End If
Next I
Application.EnableEvents = True
Module1.Ha_Rachid
End Sub

Dans un module nommé Module1 :

Code:

1
2
3
4
5
Sub Ha_Rachid()
Rows("45:55").Sort Key1:=Range("A45"), Order1:=xlAscending, Key2:=Range("A45"), Order2:=xlAscending, Header:=no, OrderCustom:=1, MatchCase _
    :=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
    DataOption2:=xlSortNormal
End Sub

26/03/2019, 16h59
Mickamax

4 pièce(s) jointe(s)

Bonjour Thautheme,
Merci pour la contribution mais cela ne semble pas fonctionner pour moi… J'ai probablement mal illustré mes besoins:

J'ai une liste de tâche avec leur priorité comme ci-dessous:

Pièce jointe 461383

Or, lorsque je modifie la priorité d'une tâche comme sur le dessin ci-dessous :

Pièce jointe 461437

Je voudrais que mon "ETC 1" passe en deuxième position automatiquement, et que mon usinage, 2ème jusqu'ici, passe en troisième position, la mise en sachet en 4ème, etc.

Avec ta macro, mon "ETC 1" se met bien en deuxième position, mais comme dans la capture qui suit :

Pièce jointe 461441

Soit deux tâches en 2ème position, et ma tâche "ETC1" qui se trouve derrière l"Usinage" alors qu'elle devrait être devant…

L'utilité de la macro peut-être mise en doute, mais la liste de projet est assez longue, et me ferait économiser un temps précieux…

PS: Bien vu le jeu de mot Thautheme...:mrgreen:

J'avais supprimé une proposition de permutation

Ci-joint correction

Code:

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Pos As Long, i As Long
Dim Tach As String
Dim Plage As Range
Dim Tb
 
If Target.Count = 1 Then
    Set Plage = Range("h18").Resize(10, 2)
    Tb = Plage.Value
    If Not Intersect(Target, Plage.Columns(1)) Is Nothing Then
        If Target.Value <= Plage.Rows.Count And Val(Target.Value) > 0 Then
            Pos = Target.Row - Plage.Row + 1
            Tach = Tb(Pos, 2)
            If Pos < Target.Value Then
                For i = Pos + 1 To Target.Value
                    Tb(i - 1, 1) = i - 1
                    Tb(i - 1, 2) = Tb(i, 2)
                Next i
                Tb(i - 1, 2) = Tach
            Else
                For i = Pos To Target.Value + 1 Step -1
                    Tb(i, 1) = i
                    Tb(i, 2) = Tb(i - 1, 2)
                Next i
                Tb(i, 2) = Tach
            End If
            Application.EnableEvents = False
            Plage.Value = Tb
            Application.EnableEvents = True
        Else
            Application.Undo
        End If
    End If
End If
End Sub

Ou en améliorant

Code:

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
 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Pos As Long, i As Long
Dim Tach As String
Dim Plage As Range
Dim newPos as Integer
Dim Tb
 
If Target.Count = 1 Then
    Set Plage = Range("A45").Resize(10,)
    Tb = Plage.Resize(,2).Value
    If Not Intersect(Target, Plage) Is Nothing Then
        If Target.Value <= Plage.Count And Val(Target.Value) > 0 Then
            Pos = Target.Row - Plage.Row + 1
            NewPos=Target.Value
            Tach = Tb(Pos, 2)
            If Pos < newPos Then
                For i = Pos  To NewPos-1
                    Tb(i , 1) = i 
                    Tb(i , 2) = Tb(i+1, 2)
                Next i
            Else
                For i = Pos To newPos + 1 Step -1
                    Tb(i, 1) = i
                    Tb(i, 2) = Tb(i - 1, 2)
                Next i
            End If
            Tb(i, 2) = Tach
            Application.EnableEvents = False
            Plage.resize(,2).Value = Tb
            Application.EnableEvents = True
        Else
            Application.Undo
        End If
    End If
End If
End Sub

Salut Mercatog,
Merci beaucoup, ça fonctionne !
J'ai juste oublié de préciser certaines choses:aie:: à côté des projets figurent des barres de couleur style diagramme de Gantt. Ton code permet bien d'intervertir les places, mais seulement les deux premières colonnes. J'ai essayé de modifier ton code pendant un petit moment pour qu'il modifie les lignes et non plus des cellules, mais mon niveau en VBA est loin d'être suffisant…

De la même manière, je pensais être prévoyant en ajoutant une variable Dligne=Range("A1500").end(XlUp).row et en ajoutant une boucle For J=45 to Dligne, afin que la sélection et le tri se fasse automatiquement dans le cas où un nouveau projet venait à apparaître, mais j'ai eu ce message d'erreur :

Citation:

"Next sans For".

Pourtant, voici mon code:
Code:

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 Private Sub Worksheet_Change(ByVal Target As Range) Dim Pos As Long, i As Long Dim Tach As String Dim Plage As Range Dim newPos As Integer Dim Tb Dim Dligne As Integer Dligne = Range("A1500").End(xlUp).Row For J = 45 To Dligne If Target.Count = 1 Then ' si j'ai s?lectionn? seulement 1 cellule alors Set Plage = Range("A45").Resize(J, 2) 'd?fini la plage comme partant de A45 et "l'?tire" jusqu'? 10 lignes et 2 colonnes Tb = Plage.Resize(J, 2).Value ' ??? Next J If Not Intersect(Target, Plage) Is Nothing Then If Target.Value <= Plage.Count And Val(Target.Value) > 0 Then 'Si la valeur de ma cellule est <au nombre de projet et qu'elle est > ? 0 alors: Pos = Target.Row - Plage.Row + 1 'ma position est ?gale ? mon num?ro de ligne dans la plage - le nombre de ligne dans la plage +1 ??? newPos = Target.Value Tach = Tb(Pos, 2) If Pos < newPos Then For i = Pos To newPos - 1 Tb(i, 1) = i Tb(i, 2) = Tb(i + 1, 2) Next i Else For i = Pos To newPos + 1 Step -1 Tb(i, 1) = i Tb(i, 2) = Tb(i - 1, 2) Next i End If Tb(i, 2) = Tach Application.EnableEvents = False Plage.Resize(, 2).Value = Tb Application.EnableEvents = True Else Application.Undo End If End If End If End Sub
Il y a bien un For et un Next, donc je ne comprend pas trop… :weird:
PS: J'ai fait des commentaires à côtés des lignes de Mercatog pour voir si j'avais bien compris la signification de celles-ci, si quelqu'un me détrompe ce serait avec grand plaisir, peut-être que ça m'aidera à y voir un peu plus clair dans ce code!

Bonne journée !

Bonjour
Combien tu as de colonnes?

Ensuite, tu as 10 priorités, tu dois avoir 10 lignes. Pourquoi DLig?. Je n'arrive pas à comprendre.

[Edit]

Pour travailler sur plusieurs colonnes N et 10 lignes à partir de A45

Code:

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newPos As Integer, N As Integer, k As Integer
Dim Pos As Long, i As Long
Dim Tach() As String
Dim Plage As Range
Dim Tb
 
If Target.Count = 1 Then
    N = 5                                                       'Nombre de colonnes
    ReDim Tach(2 To N)
    Set Plage = Range("A45").Resize(10)                         'Plage A45:A54 (10 lignes: 10 priorités)
    Tb = Plage.Resize(, N).Value                                'Dans une variable tableau on prend la matrice de 10 lignes et N colonnes
    If Not Intersect(Target, Plage) Is Nothing Then             'Si un changement s'oppère sur la priorité en colonne A
        If Target.Value <= Plage.Count And Val(Target.Value) > 0 Then   'si la priorité ne dépasse pas 10 (ou le nombre de cellules de A45:A54) et est un nombre >0
            Pos = Target.Row - Plage.Row + 1                    ' Pos la position de la ligne changée par rapport à la plage
            newPos = Target.Value                               'newPos la valeur entrée comme nouvelle priorité
            For k = 2 To N
                Tach(k) = Tb(Pos, k)                            'On mémorise les données de la ligne qui vient d'être changée
            Next k
            If Pos < newPos Then                                'Deux traitement distincts selon que pos>newpos ou nom
                For i = Pos To newPos - 1
                    Tb(i, 1) = i
                    For k = 2 To N
                        Tb(i, k) = Tb(i + 1, k)
                    Next k
                Next i
            Else
                For i = Pos To newPos + 1 Step -1
                    Tb(i, 1) = i
                    For k = 2 To N
                        Tb(i, k) = Tb(i - 1, k)
                    Next k
                Next i
            End If
            For k = 2 To N
                Tb(i, k) = Tach(k)
            Next k
            Application.EnableEvents = False
            Plage.Resize(, N).Value = Tb                        'On ré injecte le tableau sur notre plage
            Application.EnableEvents = True
        Else
            Application.Undo
        End If
    End If
End If
End Sub

27/03/2019, 10h04
Mickamax

1 pièce(s) jointe(s)

Citation:

Bonjour
Combien tu as de colonnes?

Ensuite, tu as 10 priorités, tu dois avoir 10 lignes. Pourquoi DLig?. Je n'arrive pas à comprendre.

J'ai une bonne centaine de colonne.
J'ai effectivement 10 priorités, mais il est probable que de nouveaux projets viennent s'ajouter par la suite, ou que certains disparaissent… Je voulais donc variabiliser mon nombre de ligne en fonction du nombre de projet, mais peut-être n'est-ce pas une bonne solution.

J'ai testé ton code, il est super, comme le premier, avec encore un petit problème :aie::aie:

Pièce jointe 461571

Ton code va ordonner les valeurs des cellules, mais va laisser les couleurs des cellules où elles sont… Or j'aimerai qu'il me prenne également les couleurs (toute la ligne en fait, quoi). Je pense que ça a quelque chose à voir avec le .Value mais vu mon niveau d'expertise, il y a de fortes chances que ça ne soit pas du tout ça :mouarf:

Je vais essayer de le tripoter un peu dans tous les sens mais je n'y crois pas trop!
27/03/2019, 12h41
mercatog

Mais voilà quand on donne des informations incomplètes.

C'est faisable.
Grosso modo, on identifie la cellule de priorité changée Target
On identifie ensuite la cellule c qui avait cette nouvelle priorité à l'aide de la méthode Find avec l'argument After:=Target
On insère notre ligne juste avant la ligne c.row et on y colle Target.entirerow
On supprime l'ancienne ligne de Target
On re numérote les lignes.

Si tu n'arrives pas, je le ferai dès que je serai sur mon poste.

Bonjour,

un exemple basé sur les captures du post 5 à adapter :

PRIORITÉS	TACHES
1	Tache1
2	Tache2
3	Tache3
4	Tache4
5	Tache5
6	Tache6
7	Tache7
8	Tache8
9	Tache9
10	Tache10

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, L As Long
    Set Rg = Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row)
    If Not Application.Intersect(Target, Rg) Is Nothing Then
        Application.EnableEvents = False
        L = Target:       Target.Offset(, 1).Cut
        If L <> Target.Row - 1 Then
            Rg.Item(IIf(L = Rg.Count, L + 1, L)).Offset(, 1).Insert Shift:=xlDown
            With Rg
                .Formula = "=ROW()-1"
                .Value = .Value
            End With
        End If
        Application.EnableEvents = True
    End If
    Application.CutCopyMode = False:        Set Rg = Nothing
End Sub

Idée de mon trajet au taf - fait ce midi (pas le temps avant :()

Edit : je viens de m'apercevoir une petite erreur de calcul de ligne dans un cas, je corrige dès que je peux

Bonjour Ryu, Mickamax
Une autre proposition indépendamment du début de la plage

Code:

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Plage As Range, c As Range
Dim i As Long
 
If Target.Count = 1 Then
    Set Plage = Range("A45").Resize(10)
    If Not Intersect(Target, Plage) Is Nothing Then
        If Target.Value <= Plage.Count And Val(Target.Value) > 0 Then
            'On cherche la cellule contenant l'ancienne priorité
            Set c = Plage.Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole, After:=Target)
            If Not c Is Nothing Then
                Application.EnableEvents = False
                Target.EntireRow.Copy
                c.Offset(Abs(c.Row > Target.Row)).EntireRow.Insert
                Target.EntireRow.Delete
                Set c = Nothing
                Set Plage = Range("A45").Resize(10)
                For i = 1 To Plage.Count
                    Plage.Offset(i - 1).Resize(1).Value = i
                Next i
                Application.EnableEvents = True
            End If
        Else
            Application.Undo
        End If
    End If
    Set Plage = Nothing
End If
End Sub

27/03/2019, 14h07
Mickamax

1 pièce(s) jointe(s)

Mercatog, RyuAutodidacte merci pour vos retours.

Mercatog, j'ai essayé ton code et celui-ci m'affiche le message d'erreur suivant :

Pièce jointe 461643

Le message semble venir de cette ligne de code:

Code:

c.Offset(Abs(c.Row > Target.Row)).EntireRow.Insert

J'ai essayé de tripoter par-ci par là, mais ce niveau de code dépasse largement mes maigres compétences dans le domaine… :? :?

Bonne journée,
Mickamax
27/03/2019, 14h39
mercatog

Le code je l'ai testé sur un fichier exemple sans problème.

Dans quelle situation tu as cette erreur?

Adaptation du code précédent (qui fonctionne chez moi sur un fichier exemple)

Code:

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
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Plage As Range, c As Range, Deb As Range
Dim N As Long, i As Long
Dim p As Byte
 
Set Deb = Range("A44") 'cellule des titres
If Target.Count = 1 Then
    N = Cells(Rows.Count, 2).End(xlUp).Row - Deb.Row
    If N > 1 Then
        Set Plage = Deb.Offset(1).Resize(N)
        If Not Intersect(Target, Plage) Is Nothing Then
            Application.EnableEvents = False
            If Target.Value <= Plage.Count And Val(Target.Value) > 0 Then
                Set c = Plage.Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole, After:=Target)
                If Not c Is Nothing Then
                    Target.EntireRow.Copy
                    p = Abs(c.Row > Target.Row)
                    c.Offset(p).EntireRow.Insert
                    Target.EntireRow.Delete
                    Set c = Nothing
                    Set Plage = Deb.Offset(1).Resize(N)
                    For i = 1 To Plage.Count
                        Plage.Offset(i - 1).Resize(1).Value = i
                    Next i
                End If
            Else
                Application.Undo
            End If
            Application.EnableEvents = True
        End If
        Set Plage = Nothing
    End If
End If
Set Deb = Nothing
End Sub

27/03/2019, 15h56
Mickamax

Mercatog,
ça fonctionne du tonnerre, même lorsque j'ajoute une tâche !
Béni sois-tu, toi et toute ta descendance !

Merci beaucoup !
Mickamax

:D:D

Bonsoir,

Comme dit dans mon post précédent, je repasse pour la correction de mon code, j'en ai profité pour faire qq amélio. :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, DL As Long, L As Long
    If Target.Count > 1 Then Exit Sub
        DL = Cells(Rows.Count, 2).End(xlUp).Row
        Set Rg = Range("B2:B" & DL)
        If Not Application.Intersect(Target, Rg.Offset(, -1)) Is Nothing Then
            L = Target.Value
            If L > DL - 1 Or L < 1 Then MsgBox "Choisir une valeur entre 1 et " & DL - 1:       Target.Value = Target.Row - 1
            If Target.Value = Target.Row - 1 Then Exit Sub
 
            Application.ScreenUpdating = False
            Application.EnableEvents = False
                Target.Offset(, 1).Cut
                If L >= Target.Row Then L = Rg.Item(L).Row
                Rg.Item(L).Insert Shift:=xlDown
            Application.EnableEvents = True
        End If
        With Rg.Offset(, -1)
            .Formula = "=ROW()-1"
            .Value = .Value
        End With
        Application.CutCopyMode = False:        Set Rg = Nothing
        Application.ScreenUpdating = True
End Sub

A adapter bien sur

PRIORITÉS	TACHES
1	Tache1
2	Tache2
3	Tache3
4	Tache4
5	Tache5
6	Tache6
7	Tache7
8	Tache8
9	Tache9
10	Tache10

@mercatog :plusser:

Edit : Variante en condition pour cas sortie de sub avec le re-calcul des prio :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rg As Range, DL As Long, L As Long
    If Target.Count > 1 Then Exit Sub
        DL = Cells(Rows.Count, 2).End(xlUp).Row
        Set Rg = Range("B2:B" & DL)
        If Not Application.Intersect(Target, Rg.Offset(, -1)) Is Nothing Then
            L = Target.Value
            If L > DL - 1 Or L < 1 Then MsgBox "Choisir une valeur entre 1 et " & DL - 1:       Target.Value = Target.Row - 1
            If Target.Value <> Target.Row - 1 Then
                Application.ScreenUpdating = False
                Application.EnableEvents = False
                    Target.Offset(, 1).Cut
                    If L >= Target.Row Then L = Rg.Item(L).Row
                    Rg.Item(L).Insert Shift:=xlDown
                Application.EnableEvents = True
            End If
        End If
        With Rg.Offset(, -1)
            .Formula = "=ROW()-1"
            .Value = .Value
        End With
        Application.CutCopyMode = False:        Set Rg = Nothing
        Application.ScreenUpdating = True
End Sub