XL 2021 Fixer une valeur dépend d'autre "Excel"

[Anr1]

Bonjour à tous,

Je suis à la recherche d'une méthode (Formule) pour définir l'attribut "salarié" si une occurrence de cette valeur est trouvée pour un numéro de section donné.

Par exemple : si, sur cinq lignes de la section "10", une seule valeur contient le mot "salarié" dans la colonne "CSP", alors le mot "Salarié" sera placé pour les 4 autres lignes.

Vous trouverez en pièce jointe un exemple illustrant la solution souhaitée.

Je vous remercie par avance

Cordialement.

 

[job75]

Bonjour Anr1,

Voyez le fichier joint et cette macro dans le code de la feuille :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x$, d As Object, tablo, i&
x = "Salarié"
Set d = CreateObject("Scripting.Dictionary")
With [A1].CurrentRegion.Resize(, 2)
    tablo = .Value 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If tablo(i, 1) = x Then d(tablo(i, 2)) = ""
    Next i
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 2)) Then tablo(i, 1) = x
    Next i
    '---restitution---
    Application.EnableEvents = False
    .Value = tablo
    Application.EnableEvents = True
End With
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

A+

 

[Anr1]

Merci beaucoup @job75 , c'est génial !
J'ai essayé de l'appliquer dans ma base de travail, mais ça ne fonctionne pas. La variable à changer dans ma base se trouve dans la colonne C au lieu de la colonne A, et la variable de référence se trouve dans la colonne E au lieu de la colonne B. Voici le code :

Option Explicit
Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x$, d As Object, tablo, i&
x = "SALARIE/CONJOINT/ENFANT"
Set d = CreateObject("Scripting.Dictionary")
With [C1].CurrentRegion.Resize(, 3)
    tablo = .Value 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If tablo(i, 3) = x Then d(tablo(i, 4)) = ""
    Next i
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 4)) Then tablo(i, 3) = x
    Next i
    '---restitution---
    Application.EnableEvents = False
    .Value = tablo
    Application.EnableEvents = True
End With
End Sub

Merci d'avance.

 

[job75]

D'où l'intérêt de présenter au départ un fichier représentatif.

La macro affectée au bouton dans Module1 :

Option Compare Text 'la casse est ignorée

Sub a()
Dim x$, d As Object, tablo, i&
x = "Salarié"
Set d = CreateObject("Scripting.Dictionary")
With [C1].CurrentRegion.Resize(, 3)
    tablo = .Value 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If tablo(i, 1) = x Then d(tablo(i, 3)) = ""
    Next i
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 3)) Then tablo(i, 1) = x
    Next i
    '---restitution---
    .Value = tablo
End With
End Sub

 

[Anr1]

Bonjour @job75 ,

Merci beaucoup ! La macro fonctionne très bien.

Cependant, lorsque je l'applique à mon fichier, je reçois un message d'erreur "L'indice n'appartient pas à la sélection".

Option Explicit
Option Compare Text 'la casse est ignorée

Sub a()
Dim wks As Worksheet
Set wks = Sheets("xxx")
Dim x$, d As Object, tablo, i&
x = "Salarié"
Set d = CreateObject("Scripting.Dictionary")
With [C1].CurrentRegion.Resize(, 3)
    tablo = .Value 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        If tablo(i, 3) = x Then d(tablo(i, 5)) = ""
    Next i
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 5)) Then tablo(i, 3) = x
    Next i
    '---restitution---
    .Value = tablo
End With
End Sub

Pouvez-vous me dire où se situe mon erreur s'il vous plait ?

NB : Je suis effectivement désolé de ne pas avoir fourni un fichier représentatif dès le départ 🙂

D'avance merci!

 

[job75]

Bonjour Anr1,

Sans fichier représentatif du bug je ne vois pas.

Vérifiez qu'il n'y a pas une autre macro qui crée le bug.

A+

 

[Anr1]

Bonjour Anr1,

Sans fichier représentatif du bug je ne vois pas.

Vérifiez qu'il n'y a pas une autre macro qui crée le bug.

A+

Rebonjour @job75,

Effectivement, vous avez raison, sans un fichier représentatif du bug, c'est compliqué !J'ai essayé de créer un nouveau fichier similaire à mes besoins (à l'exception du volume des données), qui présente également un bug.

Merci bcp pour votre aide.

 

[job75]

Bah vous passez votre temps à bricoler les fichiers !!!

Ce fichier n'est pas du tout le même que celui du post #3, utilisez :

Option Compare Text 'la casse est ignorée

Sub a()
Dim wks As Worksheet
Set wks = Sheets("test")
Dim x$, d As Object, tablo, i&
x = "Salarié"
Set d = CreateObject("Scripting.Dictionary")
With [A1].CurrentRegion.Resize(, 5)
    tablo = .Value 'matrice, plus rapide
   For i = 1 To UBound(tablo)
        If tablo(i, 3) = x Then d(tablo(i, 5)) = ""
   Next i
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 5)) Then tablo(i, 3) = x
    Next i
    '---restitution---
    .Value = tablo
End With
End Sub

 

[Anr1]

C'est génial ! Merci beaucoup, j'ai compris où mon code a buggé.
Bonne fin de journée.