Discussion :

[leloup84]

Bonjour,
Je cherche via une macro à détecter un doublon en colonne B et que potentiellement s'il y a un doublon en fonction de la réponse "Oui" ou "Non" sur la popup, soit je dis "Oui" pour conserver et cela doit recadence l'ensemble de la colonne, si je dis "Non" cela vide la cellule ou remet le chiffre d'origine.
Pour bien comprendre l'idée est de mettre en colonne A le nom des projets en B de mettre leur priorité.
Donc pas de doublon possible. Sachant que je peux avoir un doublon parce que je saisie une nouvelle ligne.
Mais aussi parque le projet qui était en priorité 5 devient 2 donc cela ne doit pas toucher le projet 1, mais le 2, 3 et 4 doivent du coup se décaler de +1.
A l'inverse si le projet priorité 5 je le passe en 8, c'est le 8, 7, 6 qui doivent se décaler de -1.
J'espère être clair. Car en gros l'idée est de priorisé les projets, mais surtout à la présentation à la Direction que si on priorise un projet qu'il devient urgent, le reste se décale çà ne se surperpose pas.

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
52
53
54
55
56
57
58
59
60
61
62
63
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim cell As Range
    Dim valeurOrigine As Variant
    Dim positionDupliquee As Variant
    Dim debutPlage As Long
    Dim finPlage As Long
    Dim response As Integer
 
    ' Vérifier si la modification a eu lieu dans la colonne B
    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        Application.EnableEvents = False ' Désactiver les événements pour éviter une boucle infinie
        ' Définir la plage de vérification des doublons
        Set rng = Range("B:B")
        ' Stocker la valeur d'origine de la cellule modifiée
        valeurOrigine = Target.Value2
 
        ' Vérifier s'il existe un doublon de la nouvelle valeur
        If WorksheetFunction.CountIf(rng, valeurOrigine) > 1 Then
            ' Afficher le message de doublon et demander à l'utilisateur ce qu'il souhaite faire
            response = MsgBox("Un doublon a été trouvé pour la valeur " & valeurOrigine & " dans la colonne B. " & vbNewLine & _
                                  "Voulez-vous conserver cette valeur et décaler tous les autres projets ? " & vbNewLine & _
                                  "Ou voulez-vous saisir une nouvelle valeur pour l'ordre de priorité de ce projet ?", vbQuestion + vbYesNo, "Doublon détecté")
 
            ' Si l'utilisateur choisit de conserver la valeur et décaler les autres projets
            If response = vbYes Then
                ' Déterminer la plage de valeurs à ajuster
                If valeurOrigine < Target.Value2 Then
                    debutPlage = Target.Row
                    finPlage = rng.Rows.Count
                Else
                    debutPlage = 1
                    finPlage = Target.Row
                End If
 
                ' Ajuster les valeurs dans la plage spécifiée
                For Each cell In rng.Rows(debutPlage & ":" & finPlage)
                    If Not IsEmpty(cell) Then
                        If valeurOrigine < Target.Value2 Then
                            If cell.Value2 >= Target.Value2 And cell.Value2 <> valeurOrigine Then
                                cell.Value = cell.Value + 1
                            End If
                        Else
                            If cell.Value2 > valeurOrigine And cell.Value2 <= Target.Value2 And cell.Value2 <> valeurOrigine Then
                                cell.Value = cell.Value - 1
                            End If
                        End If
                    End If
                Next cell
 
                ' Mettre à jour la valeur de la cellule modifiée
                Target.Value = valeurOrigine
            ' Si l'utilisateur choisit de saisir une nouvelle valeur
            Else
                ' Annuler la modification en restaurant la valeur d'origine
                Target.Value = valeurAncienne
                MsgBox "Veuillez saisir une nouvelle valeur pour l'ordre de priorité de ce projet."
            End If
        End If
 
        Application.EnableEvents = True ' Réactiver les événements
    End If
End Sub

[EricDgn]

Bonjour,

Une façon de faire cela:

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
Option Explicit
 
Dim oldValue, newValue
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim kFin As Long, rBB As Range, k As Long
    If Target.Count > 1 Then Exit Sub
    'Debug.Print Target.Address, Target
    If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
    Application.EnableEvents = False                                        '--- déactiver les événements
    kFin = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    Set rBB = Range("B2:B" & kFin)
    If WorksheetFunction.CountIf(rBB, Target) > 1 Then
        '--- Afficher le message de doublon et demander à l'utilisateur ce qu'il souhaite faire
        If MsgBox("Un doublon a été trouvé pour la valeur " & Target & " dans la colonne B" & vbNewLine & _
                  "Oui:  conserver cette valeur et décaler les autres projets ? " & vbNewLine & _
                  "Non: saisir une autre valeur de priorité pour ce projet ?", _
                   vbYesNo, "Doublon détecté") = vbNo Then
            Target = oldValue
            Exit Sub                '--- EXIT SUB ---
        End If
    End If
    newValue = Target
    Target = 0
    If newValue > oldValue Then
        For k = 2 To kFin
            If Range("B" & k) > oldValue Then
                If Range("B" & k) <= newValue Then
                    Range("B" & k) = Range("B" & k) - 1
                End If
            End If
        Next k
    ElseIf newValue < oldValue Then
        For k = 2 To kFin
            If Range("B" & k) < oldValue Then
                If Range("B" & k) >= newValue Then
                    Range("B" & k) = Range("B" & k) + 1
                End If
            End If
        Next k
    End If
    Target = newValue
    Application.EnableEvents = True                                                 '--- réactiver les événements
    Range("A1:B" & kFin).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes '--- tri selon colonne B:B
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    oldValue = Target.Value
    'Debug.Print Target.Address & ": " & Target.Value
End Sub

Bien cordialement.

[leloup84]

Merci pour votre code, c'est fonctionnel.