Adaption code VBA - Menu à sélection multiple

Signaler
Messages postés
75
Date d'inscription
lundi 15 juin 2015
Statut
Membre
Dernière intervention
21 novembre 2019
-
Messages postés
15256
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
3 août 2020
-
Bonjour à toi,

Il y a un peu plus de 2 ans, j'ai fais appel au forum pour mettre en place un menu déroulant à sélection multiple : https://forums.commentcamarche.net/forum/affich-34721361-menu-deroulant-a-selection-multiple#p34746067

Aujourd'hui, j'en ai à nouveau besoin, mais je peine à adapter le code qu'on m'avait donné...
A l'origine, le codage était adapté pour plusieurs colonne et aujourd'hui il faudrait que ça s'applique sur une seule colonne. Malgré que je change la plage sélectionnée, les colonnes de fournitures etc... Rien ne fonctionne. J'en appelle à vous !

A savoir, j'aimerai que le menu à sélection multiple s'applique de C7:C100

Le code appliqué sur la feuille où le menu est :
Option Explicit

' constantes décrvant la configuration - à adapter

Const plageLB As String = "C7:C100" ' plage à traiter
Const lideb As Byte = 6 ' ligne des fournitures
Const codeb As Byte = 3 ' premiere colonne fournitures
Const sep As String = " + " ' séparateur - si tu preferes une foruniture par ligne
' tu mets vblf (pour line feed)

Dim interne As Boolean

Private Sub LbLIste_Change()
Dim ch As String, i As Long
If Not interne Then
ch = ""
For i = 0 To LbListe.ListCount - 1
If LbListe.Selected(i) = True Then ch = ch & sep & LbListe.List(i)
Next i
ch = Mid(ch, Len(sep) + 1)
ActiveCell = ch
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ch As String, ch2 As String, i As Long
Dim plage, topIndex As Boolean
Dim four As String, co As Long
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range(plageLB)) Is Nothing Then LbListe.Visible = False: Exit Sub
co = Target.Column
four = Cells(lideb, co).Value
plage = PlageListe(four)
If plage = False Then
MsgBox "erreur : " & four & " n'est pas dans la feuille " & FL
Exit Sub
End If
' initialiser listbox
LbListe.ListFillRange = FL & "!" & plage
LbListe.Top = Target.Top
LbListe.Left = Target.Offset(0, 1).Left
LbListe.Width = 100
LbListe.Height = LbListe.ListCount * (ActiveCell.Font.Size + 2) + 10
LbListe.MultiSelect = fmMultiSelectMulti
topIndex = False
' maj selection dans lbListe
interne = True ' palliatif, EnableEvents ne marche pas
ch = ActiveCell
ch2 = sep & ch & sep
topIndex = False
For i = 0 To LbListe.ListCount - 1
If InStr(ch2, LbListe.List(i)) > 0 Then
' l'item a été trouvé dans la cellule
LbListe.Selected(i) = True
If Not topIndex Then
LbListe.topIndex = i ' le 1er sélectionné doit être visible dans la textbox
topIndex = True
End If
End If
Next i
interne = False
LbListe.Visible = True
End Sub


Code mis dans un module :
Option Explicit

' constantes décrvant la configuration

' Feuille Liste
Public Const FL As String = "Listes" ' nom de la feuille
Public Const liFL As Byte = 1 ' ligne des fournitures

Public Function PlageListe(F As String)
Dim n As Byte, lifin As Byte, co As Byte, obj As Object
With Sheets(FL)
Set obj = .Rows(liFL).Find(F, , , xlWhole)
If obj Is Nothing Then PlageListe = False: Exit Function
co = obj.Column
lifin = .Cells(Rows.Count, co).End(xlUp).Row
PlageListe = .Range(.Cells(liFL + 1, co), .Cells(lifin, co)).Address
End With
End Function

Sub reinit()
Application.EnableEvents = True
End Sub



Merci d'avance de prendre du temps pour solutionner mon problème !
Belle journée.


Bye bye
« Avant de rêver, il faut savoir. »

5 réponses

Messages postés
689
Date d'inscription
dimanche 15 novembre 2015
Statut
Membre
Dernière intervention
28 juillet 2020
109
Bonjour

Un essai pour le fonctionnement d'un menu à sélection multiple sur plusieurs feuilles

https://mon-partage.fr/f/Zo61T4PA/

Slts
Messages postés
75
Date d'inscription
lundi 15 juin 2015
Statut
Membre
Dernière intervention
21 novembre 2019

Bonjour,

Je te remercie beaucoup, c'est exactement ce que je souhaitais !

Par contre, je dois systématiquement cliquer sur le bouton reset pour chaque nouvelle ligne. Afin que la macro fonctionne. Est-ce qu'il y a un moyen de l'éviter ?

Merci encore.
Bien cordialement.
Messages postés
689
Date d'inscription
dimanche 15 novembre 2015
Statut
Membre
Dernière intervention
28 juillet 2020
109
Bonsoir,

Merci de mettre à la dispo un fichier anonymiser

Slts
Messages postés
75
Date d'inscription
lundi 15 juin 2015
Statut
Membre
Dernière intervention
21 novembre 2019

Bonjour,

Excusez moi pour ma réponse très tardive. J'ai eu du mal à prendre le temps d'anonymiser mon fichier !
Le voici : https://www.cjoint.com/c/IKmoH4OQShR

Information supplémentaire que je n'avais pas dit, il faudrait que ce menu déroulant à sélection multiple soit répété sur 12 feuilles (qui correspond aux 12 mois de l'année).

Dans mon fichier joint, ce serait sur la colonne "Projet" de chaque tableau qui se trouve sur les feuilles. Cette colonne correspondra toujours à la colonne C et débutera toujours à la ligne 7. Par contre le tableau mensuel est rempli au fur et à mesure. Il faut donc prendre en compte le fait qu'il puisse s'agrandir.
Les éléments de ma liste sont notés sur la feuille nommée "Listes"

Merci beaucoup pour le temps consacré !
Belle journée.
Messages postés
689
Date d'inscription
dimanche 15 novembre 2015
Statut
Membre
Dernière intervention
28 juillet 2020
109
Bonsoir,

Désolé pour la réponse tardive , mais j'étais absent.
En fait j'ai vu le problème.... mais j'ai pas réussi à trouver la solution, mise à part en mettant une macro dans chaque feuille , alors si cela te tente fais le moi savoir.
Ou alors quelqu'un d'autre "contributeur" trouvera une solution

Slts
Messages postés
75
Date d'inscription
lundi 15 juin 2015
Statut
Membre
Dernière intervention
21 novembre 2019

Bonjour,

Aucun soucis, c'est déjà très gentil de ta part de prendre le temps de trouver une solution pour moi.
J'imagine que tu répondais à mon autre message pour enlever le bouton reset ?
A ce que j'ai compris, ce bouton sert à autoriser les évènements, il n'y aurai pas un moyen de l'inclure dans la macro que tu as créé ? Afin d'éviter de devoir cliquer dessus à chaque nouvelle ligne du tableau.

Belle journée.
Messages postés
689
Date d'inscription
dimanche 15 novembre 2015
Statut
Membre
Dernière intervention
28 juillet 2020
109
Bonjour,

En fait je l'avais déjà inclut dans le fichier du post3 mais malheureusement ça ne fonctionne pas. Alors comme je te l'ai dit avec une macro dans chaque feuille ça devrait fonctionner, alors si cela te tente..... à moins qu'un contributeur aurait une solution
Application.EnableEvents = True


Slts
Messages postés
75
Date d'inscription
lundi 15 juin 2015
Statut
Membre
Dernière intervention
21 novembre 2019

Bonjour,

Ah oui je vois où est cette partie !
Et bien si cela ne te dérange pas, oui j'aimerai bien mettre une macro sur chaque feuille si cela peut éviter de cliquer sur le bouton "Reset" à chaque nouvelle ligne du tableau.

Belle journée.
Messages postés
15256
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
3 août 2020
1 318
Bonjour a vous deux,

The_Boss_68:
Vous écrivez que
Application.EnableEvents = True
ne fonctionne pas. Dans quel cas et sur quelle erreur??
Messages postés
689
Date d'inscription
dimanche 15 novembre 2015
Statut
Membre
Dernière intervention
28 juillet 2020
109
Bonsoir f894009

Voir la macro dans ThisWorkbook du fichier post #3

En fait dans la plage C7:C9 il y a une liste déroulante à choix multiples, le problème récurant actuel est...... lorsque l'on rajoute une ligne sous C9 la liste déroulante à choix multiples ne fonctionne plus, il faut appuyer sur reset pour qu'elle re-fonctionne alors le demandeur Liitch avait suggérer d'inclure
Application.EnableEvents = True dans la macro pour éviter d'appuyer chaque fois sur reset pour que la liste déroulante à choix multiples re-fonctionne de nouveau, je lui ai dis que Application.EnableEvents = True était déjà inclu dans la macro et qu’apparemment cela ne Reset pas automatiquement

Pour info f894009 s'il tu aurais une solution ce serait le top

Slts
Messages postés
15256
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
3 août 2020
1 318
Bonjour,

J'avais recupere le fichier et apres différents essais sans traitement d'erreur (on error….):
_Ajout ligne au tableau en dessous, pas systématiquement blocage events
_Ecriture dans des cellules en en dehors du tableau dans la plage fixe C7:C20 ou autres(ai fais tellement d'essais que ….), blocage systematique
_Copier une cellule, idem
Avec le code suivant il semblerait que ce soit resolu, a testez

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim Arr(), MaFeuille As String, RG As Range
    
    On Error GoTo fin
    'D?finis la liste des onglets des feuilles o? la macro doit s'appliquer.
    'Ta liste peut ?tre aussi longue que tu veux
    If Target = "" Or Target.Count > 1 Then Exit Sub
    Arr = Array("JAN", "FEV", "MARS", "AVRIL", "MAI", "JUIN", "JUILLET", "AOUT", "SEPT", "OCT", "NOV", "DEC")
    MaFeuille = Sh.Name
    x = Application.Match(MaFeuille, Arr, 0)
    If IsNumeric(x) Then
        'adaptation de la Plage au nombre de lignes du tableau
        AdrT = Range("PDC_" & MaFeuille).Address
        LT = Split(AdrT, "$")                   'decoupage adresse du tableau PDC_MMM
        Set RG = Target
        If Not Intersect(Range("C7:C" & LT(4)), RG) Is Nothing Then
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            ValSaisie = RG
            Application.Undo
            p = InStr(RG, ValSaisie)
            If p > 0 Then
                RG = Left(RG, p - 1) & Mid(RG, p + Len(ValSaisie) + 4)
                If Right(RG, 4) = " , " Then
                    RG = Left(RG, Len(RG) - 4)
                End If
            Else
                If RG = "" Then
                    RG = ValSaisie
                Else
                    RG = RG & " , " & ValSaisie
                End If
            End If
        End If
    End If
fin:
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub


Par contre Liitch, sur ajout lignes tableau (ex:Aout), y a comme un bleme au niveau des formules!!!
Messages postés
689
Date d'inscription
dimanche 15 novembre 2015
Statut
Membre
Dernière intervention
28 juillet 2020
109
Bonjour f894009,

Merci pour moi et Liitch , effectivement après différent essais.... ta macro, fonctionne sans aucune erreur

Merci

Slts
Messages postés
15256
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
3 août 2020
1 318
Service...