[VBA] Liste déroulante avec assignation macro

Bonjour à tous ,

Je souhaites créer une liste déroulante via le contrôle de formulaire et l'assigner à une macro.
J'aimerais via VBA pouvoir assigner un nom à une macro pour chaque sélection et non pas en spécifiant une liste de nom présent dans des cellules.

Est-ce faisable ?

Bonjour,

Oui, c'est faisable, probablement ... mais là je n'ai pas tout compris, notamment les termes

assigner un nom à une macro pour chaque sélection

pas en spécifiant une liste de nom présent dans des cellules

as-tu un fichier où tu expliques cela en long et en large sur un exemple concret ?

Peut être que c'est un peu plus clair comme ça .
Redis-moi si c'est toujours pas compréhensible .

8classeur1.xlsx (19.31 Ko)
image

ok compris, je regarde

cette liste de macro doit-elle elle aussi être établie en auto (en scrutant un module par exemple) ou est-elle inscrite en dur dans la macro ?

En dur dans la macro ça me va très bien

Plutôt qu'un contrôle activeX, j'ai utilisé une cellule.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    choix = Array("test1", "test2", "test3")
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(choix, ",")
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    If Target.Value <> "" Then Application.Run Target.Value
End Sub
56classeur1.xlsm (24.30 Ko)

Si tu ne veux pas taper en dur toutes tes macros ...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(choix("MesMacros"), ",")
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    If Target.Value <> "" Then Application.Run Target.Value
End Sub
Function choix(NomDuModule As String) As Variant()
'Nécéssite d'activer la référence "Microsoft Visual basic For Application Extensibility 5.3"
    Dim temp()
    n = 0
    For n = 1 To ActiveWorkbook.VBProject.VBComponents.Count
        With ActiveWorkbook.VBProject.VBComponents(n).CodeModule
            If .Name = NomDuModule Then
                Debut = .CountOfDeclarationLines + 1
                Do Until Debut >= .CountOfLines
                    n = n + 1
                    ReDim Preserve temp(n)
                    temp(n) = .ProcOfLine(Debut, vbext_pk_Proc)
                    Debut = Debut + .ProcCountLines(.ProcOfLine(Debut, vbext_pk_Proc), vbext_pk_Proc)
                Loop
            End If
        End With
    Next
    choix = temp
End Function

Super c'est très gentil !

Merci beaucoup !!

Est-ce possible de choisir un nom par rapport à une macro ?
Exemple : le texte "Salut les gars" déclenchent la macro "test1" ?

Et... Un peu rien à voir pour le coup mais... Est-ce faisable de faire apparaître cette liste déroulante en cliquant plutôt sur une forme (exemple un rectangle) ?

Est-ce possible de choisir un nom par rapport à une macro ?
Exemple : le texte "Salut les gars" déclenchent la macro "test1" ?

Oui, mais il faut stocker ce nom quelque part, dans la macro ou comme commentaire juste après la ligne sub, c'est possible.

Et... Un peu rien à voir pour le coup mais... Est-ce faisable de faire apparaître cette liste déroulante en cliquant plutôt sur une forme (exemple un rectangle) ?

Oui aussi, dans ce cas le clic sur l'image déclenche un userform avec la liste déroulante.

.

Je vais commencer par le premier point

Pour le point 1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    Target.Validation.Delete
    Target.Validation.Add xlValidateList, Formula1:=Join(choix("MesMacros"), ",")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
    Set ici = Target
    If ici.Value <> "" Then onyva (ici.Value)
    ici.Offset(1, 0).Select
End Sub
Dim dico As Object

Function choix(NomDuModule As String) As Variant()
'Nécéssite d'activer la référence "Microsoft Visual basic For Application Extensibility 5.3"
    Dim temp()
    Set dico = CreateObject("Scripting.Dictionary")

    n = 0
    For n = 1 To ActiveWorkbook.VBProject.VBComponents.Count
        With ActiveWorkbook.VBProject.VBComponents(n).CodeModule
            If .Name = NomDuModule Then
                For i = 1 To .CountOfLines
                    If .Lines(i, 1) Like "Sub*" Then
                        n = n + 1
                        ReDim Preserve temp(n)
                        temp(n) = Replace(.Lines(i + 1, 1), "'", "")
                        dico(temp(n)) = Replace(Replace(.Lines(i, 1), "Sub ", ""), "()", "")
                    End If
                Next
            End If
        End With
    Next
    choix = temp
End Function

Sub onyva(txt As String)
    Application.Run dico(txt)
End Sub

Contenu du module MesMacros, pas d'espace entre l'apostroph et le commentaire repris dans le menu déroulant.

Sub test1()
'Hello !
    MsgBox "macro test1 exécutée avec succès !"
End Sub

Sub test2()
'Vous êtes ici ...
    MsgBox "macro test2 exécutée avec succès !"
End Sub

Sub test3()
'En avant !
    MsgBox "macro test3 exécutée avec succès !"
End Sub

je vais voir pour créer le userform (beurk !)

version avec clic sur image

Private Sub UserForm_Initialize()
    NomDuModule = "MesMacros"
    Me.ComboBox1.Clear
    Me.ComboBox2.Clear
    For n = 1 To ActiveWorkbook.VBProject.VBComponents.Count
        With ActiveWorkbook.VBProject.VBComponents(n).CodeModule
            If .Name = NomDuModule Then
                For i = 1 To .CountOfLines
                    If .Lines(i, 1) Like "Sub*" Then
                        Me.ComboBox1.AddItem Split(.Lines(i + 1, 1) & "|No Comment !|", "|")(1)
                        Me.ComboBox2.AddItem Replace(Replace(.Lines(i, 1), "Sub ", ""), "()", "")
                    End If
                Next
            End If
        End With
    Next
End Sub

Private Sub ComboBox1_Change()
    mamacro = ComboBox2.List((ComboBox1.ListIndex))
    Me.Hide
    Application.Run mamacro
End Sub
' mettre commentaires entre |abcde|

Sub test1()
' |Dormir me fatigue|
    MsgBox "macro test1 exécutée avec succès !"
End Sub

Sub test2()
' |Je pompe donc je suis|
    MsgBox "macro test2 exécutée avec succès !"
End Sub

Sub test3()
' GA BU ZO MEU
    MsgBox "macro test3 exécutée avec succès !"
End Sub

Merci bien Steelson pour toute cette aide !

Je vais voir comment j'arrive à implémenter ça dans mon fichier avec un design un peu plus neutre

Je te redis, merci encore !

Evolution ... c'est mieux avec une listbox (moins de clic)

Bonjour Steelson,

Avec ton dernier fichier avec la listbox, lorsque je protège mon projet j'ai un message d'erreur qui apparaît :

image

Aurais-tu une solution ?

C'est-à-dire "protéger le projet" ? le code VBA ?

La solution st dans ce cas de revenir à un programmation des paramètres en "dur" dans le code, sans vouloir rechercher automatiquement les macros et commentaires.

Private Sub UserForm_Initialize()
    mymacros = Array("test1", "test2", "test3")
    mycomments = Array("Dormir me fatigue", "Je pompe donc je suis", "GA BU ZO MEU")

    NomDuModule = "MesMacros"
    Me.ListBox1.Clear
    Me.ComboBox2.Clear
    For n = 0 To UBound(mymacros)
        Me.ListBox1.AddItem mycomments(n)
        Me.ComboBox2.AddItem mymacros(n)
    Next

End Sub

Private Sub ListBox1_Change()
    mamacro = ComboBox2.List((ListBox1.ListIndex))
    Me.Hide
    Application.Run mamacro
End Sub

Merci, c'est très gentil !
Oui, c'était protéger le code VBA.
Cette fois ça marche !

Une petite question encore... Lorsque je sélectionne "Dormir de fatigue" par exemple, je n'arrive pas à sélectionner à nouveau la même chose pour relancer encore une fois la macro.

Est-ce possible de corriger cela ?

En effet !! je corrige avec ListBox1.ListIndex = -1

Private Sub UserForm_activate()
    mymacros = Array("test1", "test2", "test3")
    mycomments = Array("Dormir me fatigue", "Je pompe donc je suis", "GA BU ZO MEU")

    NomDuModule = "MesMacros"
    Me.ListBox1.Clear
    Me.ComboBox2.Clear
    For n = 0 To UBound(mymacros)
        Me.ListBox1.AddItem mycomments(n)
        Me.ComboBox2.AddItem mymacros(n)
    Next
    ListBox1.ListIndex = -1

End Sub

Private Sub ListBox1_Change()
    If ListBox1.ListIndex = -1 Then Exit Sub
    mamacro = ComboBox2.List((ListBox1.ListIndex))
    Me.Hide
    Application.Run mamacro
End Sub

Super merci beaucoup !

Rechercher des sujets similaires à "vba liste deroulante assignation macro"