XL 2016 création liste déroulante choix multiple

maroue

XLDnaute Nouveau
Bonjour à tous,

Je me permets ce message pour requérir a votre savoir en VBA .
Pour mon travail je dois faire un tableau ou dans la derniére colonne (thème) il est possible de mettre plusieurs proposition et cela sur tout les onglets présents. Dans le premier onglet (BD) la liste des propositions des thèmes souhaités.
Et si vous le pouvez pourriez vous m'indiquer la marche a suivre si il y a ajout d'un onglet
Je vous joint le fichier anonymisé . j'ai déjà tenté mais en vain de réussir ma manœuvre :/ .
Je vous remercie par avance pour vos conseils et savoirs faire .
Cordialement
 

Pièces jointes

  • Bons interprètesV2.xlsx
    166.1 KB · Affichages: 19

frangy

XLDnaute Occasionnel
Bonjour,

Tu n'as pas besoin de VBA.
La plage contenant les propositions a été nommée "théme".
Il suffit donc de créer une liste de validation avec la source =théme dans la première cellule F2 et de copier cette cellule en faisant glisser la poignée de recopie.
De plus, si l'onglet ajouté est copié depuis un modèle, la liste s'ajoutera automatiquement.

Cordialement.
 

frangy

XLDnaute Occasionnel
Dans la colonne F de la feuille "AAA", les cellules contiennent une liste de validation correspondant à la plage "théme".
Pour visualiser la validation, sélectionner F2, puis : Onglet Données > Outils de données / Validation des données.
 

Pièces jointes

  • Bons interprètes.xlsx
    169.2 KB · Affichages: 22

job75

XLDnaute Barbatruc
Bonjour maroue, frangy,
Mais cela ne fait pas un choix multiple ( mettre plusieurs thème dans une cellule ) ?? Si??
Alors voyez le fichier joint et ces 2 macros dans ThisWorkbook :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "BD" Then Exit Sub
Sh.Activate
[F:F].Validation.Delete
If Intersect(ActiveCell, Range("F2:F" & Rows.Count)) Is Nothing Then Exit Sub
ActiveCell.Validation.Add xlValidateList, Formula1:="=" & [théme].Address(External:=True) 'voir orthographe de théme...
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Range("F2:F" & Sh.Rows.Count)) Is Nothing Or Target.Count > 1 Then Exit Sub
Dim mem$
Application.ScreenUpdating = False
If Target <> "" Then
    Application.EnableEvents = False
    Application.Undo: mem = Target: Application.Undo
    If mem <> "" Then If MsgBox("Faut-il ajouter ce thème au(x) thème(s) de la cellule ?", 4) = 7 Then mem = ""
    Target = IIf(mem = "", "", mem & vbLf) & Target
    Target.WrapText = mem <> "" 'renvoi à la ligne
    Application.EnableEvents = True
End If
Target.EntireRow.AutoFit 'ajustement hauteur
If Target.RowHeight < 20 Then Target.RowHeight = 20
End Sub
Puisque ces macros sont dans ThisWorkbook il n'y a rien à faire quand on crée un nouvel onglet.

A+
 

Pièces jointes

  • Bons interprètes(1).xlsm
    186.2 KB · Affichages: 15

job75

XLDnaute Barbatruc
Je n'avais pas fait attention, pour les feuilles MR MA NPP PV RF ZZ la colonne à traiter est la colonne G, pas génial...

Mais qu'à cela ne tienne, voyez la macro complétée dans ce fichier (2) :
VB:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name = "BD" Then Exit Sub
Sh.Activate
[F:G].Validation.Delete
If Intersect(ActiveCell, Range(IIf([F1] Like "Th?me", "F2:F", "G2:G") & Rows.Count)) Is Nothing Then Exit Sub
ActiveCell.Validation.Add xlValidateList, Formula1:="=" & [théme].Address(External:=True) 'voir orthographe de théme...
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Sh.Range(IIf(Sh.[F1] Like "Th?me", "F2:F", "G2:G") & Sh.Rows.Count)) Is Nothing Or Target.Count > 1 Then Exit Sub
Dim mem$
Application.ScreenUpdating = False
If Target <> "" Then
    Application.EnableEvents = False
    On Error GoTo 1 'si revalidation manuelle
    Application.Undo: mem = Target: Application.Undo
    If mem <> "" Then If MsgBox("Faut-il ajouter ce thème au(x) thème(s) de la cellule ?", 4) = 7 Then mem = ""
    Target = IIf(mem = "", "", mem & vbLf) & Target
    Target.WrapText = mem <> "" 'renvoi à la ligne
1    Application.EnableEvents = True
End If
Target.EntireRow.AutoFit 'ajustement hauteur
If Target.RowHeight < 20 Then Target.RowHeight = 20
End Sub
 

Pièces jointes

  • Bons interprètes(2).xlsm
    186.8 KB · Affichages: 31
Dernière édition:

Discussions similaires

Réponses
15
Affichages
483

Statistiques des forums

Discussions
311 707
Messages
2 081 734
Membres
101 809
dernier inscrit
HADER2024