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
 

Fichiers joints

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.
 

maroue

XLDnaute Nouveau
Mais cela ne fait pas un choix multiple ( mettre plusieurs thème dans une cellule ) ?? Si??
 

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.
 

Fichiers joints

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+
 

Fichiers joints

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
 

Fichiers joints

Dernière édition:

maroue

XLDnaute Nouveau
Bonjour Job75 et Frangy,

Merci beaucoup pour votre aide j'y aurais passée la nuit(voir des jours lol ) me connaissant sans y arrivée au final ;) .
Je vous souhaite une excellente journée et encore merci :)
 

job75

XLDnaute Barbatruc
Bonjour maroue, le forum,

La revalidation d'une cellule contenant plusieurs thèmes créait un bug, j'ai ajouté un contrôle d'erreur au post #6 avec On Error GoTo 1.

Bonne journée.
 

Discussions similaires


Haut Bas