Discussion :

[Mickamax]

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 :

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

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,

[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.

[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

[Thautheme]

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 :

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
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 :

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

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

[Mickamax]

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:



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



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 :



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...

[mercatog]

J'avais supprimé une proposition de permutation

Ci-joint correction

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
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