XL 2010 Attribuer ou Changer la valeur d'une cellule en validation de données

Sirberthoult · 2 Mai 2024

Bonjour le forum,

Je souhaiterais dans mon exemple, que dans chaque lignes, les cellules des colonnes B,D et F n'aient jamais 2 fois la même valeur.

- donc en B si je choisi "titi", puis en D si je choisi "tata" alors "toto" s'inscrit logiquement en F.

- si finalement je décide de remplacer en colonne D le "tata" en "toto" alors le "toto" en F se transforme en "tata". pour qu'il n'y ai jamais 2 fois la même valeur...

merci d'avance à toutes personnes pouvant me trouver une solution ou une piste

cordialement.

Sirberthoult · 18 Mai 2024

Bonjour le forum, Piga25, job75,

Merci Piga25 d'avoir "combiner" les 2 codes, effectivement ca fonctionne bien mais que le matin, ce qui est deja pas mal ...

j'ai tenter de faire comme toi pour faire appliquer le bout de code au bon moment mais ca bug... que penses tu de ma syntaxe ?

VB:

Private Sub Worksheet_Change(ByVal Target As Range)

If ActiveCell.Column = 2 And Range("K4") = "" Or ActiveCell.Column = 4 And Range("K4") = "" Or ActiveCell.Column = 6 And Range("K4") = "" Then 'si matin et 2 agents

    GoTo deuxdumatin

ElseIf ActiveCell.Column = 3 And Range("L4") = "" Or ActiveCell.Column = 3 And Range("L4") = "" Or ActiveCell.Column = 3 And Range("L4") = "" Then ' si aprem et 2 agents

    GoTo deuxdaprem

ElseIf ActiveCell.Column = 2 And Range("K4") <> "" Or ActiveCell.Column = 4 And Range("K4") <> "" Or ActiveCell.Column = 6 And Range("K4") <> "" Then 'si matin et 3 agents

    GoTo Troisdumatin

Else

    GoTo Troisdaprem 'sinon aprem et 3 agents
End If

deuxdumatin:
Dim un As Range, deux As Range, form1, xrg As Range, x, n&, s(0 To 1), v
   On Error GoTo FIN:
   If Target.Count > 1 Then Exit Sub
   If Target = "" Then Exit Sub
   Set un = Target
 
   If un.Column = Range("b2").Column Then
      Set deux = Cells(Target.Row, "d")

   ElseIf un.Column = Range("d2").Column Then
      Set deux = Cells(Target.Row, "b")
   ElseIf un.Column = Range("c2").Column Then
      Set deux = Cells(Target.Row, "e")
   ElseIf un.Column = Range("e2").Column Then
      Set deux = Cells(Target.Row, "c")
   End If
   form1 = Target.Validation.Formula1
   If Left(form1, 1) = "=" Then
      Set xrg = Range(Mid(form1, 2))
      If xrg.Count <> 2 Then Exit Sub
      For Each x In xrg.Value: s(n) = x: n = n + 1: Next
   Else
      v = Split(form1, Application.International(xlListSeparator))
      If UBound(v) - LBound(v) + 1 <> 2 Then Exit Sub
      s(0) = v(0): s(1) = v(1)
   End If
   Application.EnableEvents = False: deux.Value = IIf(un.Value = s(0), s(1), s(0))
FIN:
   Application.EnableEvents = True
  
  
GoTo FinProc


deuxdaprem:
Dim un As Range, deux As Range, form1, xrg As Range, x, n&, s(0 To 1), v
   On Error GoTo FIN:
   If Target.Count > 1 Then Exit Sub
   If Target = "" Then Exit Sub
   Set un = Target
 
   If un.Column = Range("c2").Column Then
      Set deux = Cells(Target.Row, "e")

   ElseIf un.Column = Range("e2").Column Then
      Set deux = Cells(Target.Row, "c")
   ElseIf un.Column = Range("d2").Column Then
      Set deux = Cells(Target.Row, "f")
   ElseIf un.Column = Range("f2").Column Then
      Set deux = Cells(Target.Row, "d")
   End If
   form1 = Target.Validation.Formula1
   If Left(form1, 1) = "=" Then
      Set xrg = Range(Mid(form1, 2))
      If xrg.Count <> 2 Then Exit Sub
      For Each x In xrg.Value: s(n) = x: n = n + 1: Next
   Else
      v = Split(form1, Application.International(xlListSeparator))
      If UBound(v) - LBound(v) + 1 <> 2 Then Exit Sub
      s(0) = v(0): s(1) = v(1)
   End If
   Application.EnableEvents = False: deux.Value = IIf(un.Value = s(0), s(1), s(0))
FIN:
   Application.EnableEvents = True


GoTo FinProc


Troisdumatin:
Dim liste, i&, j%, P As Range, c As Range, k, cc As Range
Set Target = Intersect(Target, Union(Columns("B"), Columns("D"), Columns("F")), UsedRange)
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples
    liste = Range("K2:K4")
    i = Target.Row
    j = Target.Column
    Set P = Union(Cells(i, "B"), Cells(i, "D"), Cells(i, "F"))
    Select Case Application.CountA(P)
        Case 2
            For Each c In P
                For k = 1 To 3
                    If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                Next k
                If c.Column <> j And c = Target Then Target = "": GoTo 1 'si doublon
            Next c
            For Each c In P
                If c = "" Then
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then c = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next c
        Case 3
            For Each cc In P
                If cc.Column <> j And cc = Target Then
                    For Each c In P
                        For k = 1 To 3
                            If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                    Next k, c
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then cc = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next cc
    End Select
1 Next Target
Application.EnableEvents = True 'réactive les évènements


GoTo FinProc


Troisdaprem:
Dim liste, i&, j%, P As Range, c As Range, k, cc As Range
Set Target = Intersect(Target, Union(Columns("C"), Columns("E"), Columns("G")), UsedRange)
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples
    liste = Range("L2:L4")
    i = Target.Row
    j = Target.Column
    Set P = Union(Cells(i, "C"), Cells(i, "E"), Cells(i, "G"))
    Select Case Application.CountA(P)
        Case 2
            For Each c In P
                For k = 1 To 3
                    If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                Next k
                If c.Column <> j And c = Target Then Target = "": GoTo 1 'si doublon
            Next c
            For Each c In P
                If c = "" Then
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then c = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next c
        Case 3
            For Each cc In P
                If cc.Column <> j And cc = Target Then
                    For Each c In P
                        For k = 1 To 3
                            If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                    Next k, c
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then cc = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next cc
    End Select
1 Next Target
Application.EnableEvents = True 'réactive les évènements

FinProc:

End Sub

piga25 · 18 Mai 2024

Bonjour,
Peut être une piste
Dans Private Sub Worksheet_Change(ByVal Target As Range) mettre deux conditions:
Une pour le matin (colonne pair) -----> appel procédure MATIN
L'autre pour l'APM (Colonne impair) ----> appel procédure APM
MATIN et APM étant dans Module

Sirberthoult · 18 Mai 2024

Re

effectivement ton idée juste,... alors j'ai fais ca mais ca ne fonctionne pas... je dois zapper quelque chose.

VB:

Private Sub Worksheet_Change(ByVal Target As Range)

   
    If ActiveCell.Column = 2 Or ActiveCell.Column = 4 Or ActiveCell.Column = 6 Then
    matin
    Else: aprem
    End If
   
End Sub

ou

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

   
    If ActiveCell.Column Mod 2 <> 0 Then
    matin
    Else: aprem
    End If
    End Sub

avec dans le module 1 ;

Code:

Sub matin()
If Range("K4") = "" Then GoTo deux:
Trois:
Dim liste, i&, j%, P As Range, c As Range, k, cc As Range
Set Target = Intersect(Target, Union(Columns("B"), Columns("D"), Columns("F")), UsedRange)
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples
    liste = Range("K2:K4")
    i = Target.Row
    j = Target.Column
    Set P = Union(Cells(i, "B"), Cells(i, "D"), Cells(i, "F"))
    Select Case Application.CountA(P)
        Case 2
            For Each c In P
                For k = 1 To 3
                    If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                Next k
                If c.Column <> j And c = Target Then Target = "": GoTo 1 'si doublon
            Next c
            For Each c In P
                If c = "" Then
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then c = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next c
        Case 3
            For Each cc In P
                If cc.Column <> j And cc = Target Then
                    For Each c In P
                        For k = 1 To 3
                            If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                    Next k, c
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then cc = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next cc
    End Select
1 Next Target
Application.EnableEvents = True 'réactive les évènements

deux:
Dim un As Range, deux As Range, form1, xrg As Range, x, n&, s(0 To 1), v
   On Error GoTo FIN:
   If Target.Count > 1 Then Exit Sub
   If Target = "" Then Exit Sub
   Set un = Target
 
   If un.Column = Range("b2").Column Then
      Set deux = Cells(Target.Row, "d")

   ElseIf un.Column = Range("d2").Column Then
      Set deux = Cells(Target.Row, "b")
   ElseIf un.Column = Range("c2").Column Then
      Set deux = Cells(Target.Row, "e")
   ElseIf un.Column = Range("e2").Column Then
      Set deux = Cells(Target.Row, "c")
   End If
   form1 = Target.Validation.Formula1
   If Left(form1, 1) = "=" Then
      Set xrg = Range(Mid(form1, 2))
      If xrg.Count <> 2 Then Exit Sub
      For Each x In xrg.Value: s(n) = x: n = n + 1: Next
   Else
      v = Split(form1, Application.International(xlListSeparator))
      If UBound(v) - LBound(v) + 1 <> 2 Then Exit Sub
      s(0) = v(0): s(1) = v(1)
   End If
   Application.EnableEvents = False: deux.Value = IIf(un.Value = s(0), s(1), s(0))
FIN:
   Application.EnableEvents = True


End Sub


Sub aprem()
If Range("L4") = "" Then GoTo deux:
Trois:
Dim liste, i&, j%, P As Range, c As Range, k, cc As Range
Set Target = Intersect(Target, Union(Columns("C"), Columns("E"), Columns("G")), UsedRange)
If Target Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each Target In Target 'si entrées multiples
    liste = Range("L2:L4")
    i = Target.Row
    j = Target.Column
    Set P = Union(Cells(i, "C"), Cells(i, "E"), Cells(i, "G"))
    Select Case Application.CountA(P)
        Case 2
            For Each c In P
                For k = 1 To 3
                    If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                Next k
                If c.Column <> j And c = Target Then Target = "": GoTo 1 'si doublon
            Next c
            For Each c In P
                If c = "" Then
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then c = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next c
        Case 3
            For Each cc In P
                If cc.Column <> j And cc = Target Then
                    For Each c In P
                        For k = 1 To 3
                            If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                    Next k, c
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then cc = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next cc
    End Select
1 Next Target
Application.EnableEvents = True 'réactive les évènements

deux:
Dim un As Range, deux As Range, form1, xrg As Range, x, n&, s(0 To 1), v
   On Error GoTo FIN:
   If Target.Count > 1 Then Exit Sub
   If Target = "" Then Exit Sub
   Set un = Target
 
   If un.Column = Range("c2").Column Then
      Set deux = Cells(Target.Row, "e")

   ElseIf un.Column = Range("e2").Column Then
      Set deux = Cells(Target.Row, "c")
   ElseIf un.Column = Range("d2").Column Then
      Set deux = Cells(Target.Row, "f")
   ElseIf un.Column = Range("f2").Column Then
      Set deux = Cells(Target.Row, "d")
   End If
   form1 = Target.Validation.Formula1
   If Left(form1, 1) = "=" Then
      Set xrg = Range(Mid(form1, 2))
      If xrg.Count <> 2 Then Exit Sub
      For Each x In xrg.Value: s(n) = x: n = n + 1: Next
   Else
      v = Split(form1, Application.International(xlListSeparator))
      If UBound(v) - LBound(v) + 1 <> 2 Then Exit Sub
      s(0) = v(0): s(1) = v(1)
   End If
   Application.EnableEvents = False: deux.Value = IIf(un.Value = s(0), s(1), s(0))
FIN:
   Application.EnableEvents = True


End Sub

job75 · 18 Mai 2024

Bonjour Sirberthoult, piga25,

Je me décide à intervenir, voyez cette macro :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim liste, j%, i As Variant, c As Range, p As Range, k%, cc As Range
On Error Resume Next
liste = Evaluate(Target.Validation.Formula1)
On Error GoTo 0
If Not IsArray(liste) Then Exit Sub
Application.EnableEvents = False
j = Target.Column
'---liste à 2 élémebts---
If UBound(liste) = 2 Then
    i = Application.Match(Target, liste, 0)
    Set c = Cells(Target.Row, Switch(j = 2, 4, j = 3, 5, j = 4, 2, j = 5, 3, True, j))
    If IsError(i) Then
        i = Application.Match(c, liste, 0)
        If IsError(i) Then Target = "": c = "" Else Target = liste(3 - i, 1)
    Else
        c = liste(3 - i, 1)
    End If
'---liste à 3 élémebts---
ElseIf UBound(liste) = 3 Then
    i = Target.Row
    If j = 2 Or j = 4 Or j = 6 Then Set p = Union(Cells(i, "B"), Cells(i, "D"), Cells(i, "F"))
    If j = 3 Or j = 5 Or j = 7 Then Set p = Union(Cells(i, "C"), Cells(i, "E"), Cells(i, "G"))
    If p Is Nothing Then GoTo 1
    Select Case Application.CountA(p)
        Case 2
            For Each c In p
                For k = 1 To 3
                    If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                Next k
                If c.Column <> j And c = Target Then Target = "": GoTo 1 'si doublon
            Next c
            For Each c In p
                If c = "" Then
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then c = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next c
        Case 3
            For Each cc In p
                If cc.Column <> j And cc = Target Then
                    For Each c In p
                        For k = 1 To 3
                            If liste(k, 1) = c Then liste(k, 1) = "": Exit For
                    Next k, c
                    For k = 1 To 3
                        If liste(k, 1) <> "" Then cc = liste(k, 1): GoTo 1 'valeur restante
                    Next k
                End If
            Next cc
    End Select
End If
1 Application.EnableEvents = True
End Sub

Dans la SelectionChange CreateObject("WScript.Shell") évite la désactivation du pavé numérique.

A+

Sirberthoult · 18 Mai 2024

Bonsoir le forum, Job75, Piga25

C'est Parfait ! exactement ce que je souhaitais !

merci à toi Job75, d'avoir repondu à ma demande initiale et d'avoir finaliser l'integration de la solution dans mon fichier.

merci à toi Piga25, de m'avoir proposé des solutions et des pistes pour tenter de solutionner mon probléme.

bon weekend
A+

Effectuez une recherche sur Excel Downloads...

XL 2010 Attribuer ou Changer la valeur d'une cellule en validation de données

Sirberthoult

XLDnaute Occasionnel

Pièces jointes

job75

Sirberthoult

XLDnaute Occasionnel

Pièces jointes

piga25

XLDnaute Barbatruc

Sirberthoult

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

Sirberthoult

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums