Aide à la création de liste...dans liste...sur même cellule pour tableau

Bonjour,

Je souhaite créer une liste déroulante de catégorie principale (H1/J1/L1) qui "filtre" les profession (H/J/L) pour facilité l'inscription et éviter une trop longue liste déroulante et diminuer le nombre de colonnes dans le tableau

je voudrais que la formule se répète sur les lignes suivante à chaque nouvelle entrée de contact.

Voici une capture d'écran plus explicative

Merci pour votre aide précieuse

Sincèrement

Julien LHERBÉ

Classeur 3

Bonjour,

Une proposition ?

Cdlt.

Merci Jean Eric,

Plutôt interessant et je basculerais vers cette solution si jamais. Vous croyez possible de n'avoir qu'une seule colonne?

Clic sur liste Catégorie , sélection "commerce" qui ouvre l'accès aux sous catégories pour inscrire l'activité

Mon tableau final comprends beaucoup de colonnes, le but étant de limiter le nombre de celles ci.

Merci pour votre temps.

Bonjour,

Une proposition VBA "usine à gaz".

Disons que j'ai sorti les grenades pour exterminer 2 termites...

Dans un module standard :

Option Explicit

Public Const NOMPOPUP As String = "MonMenu"

'---- Déterminer les coordonnées en pixels, par rapport à l'écran, du coin supérieur gauche d'une cellule Excel
Private Type position
    Left As Integer
    Top As Integer
End Type
Private Const GARDEFOU As Byte = 20
Public Function Place_Curseur(Cellule As Range) As position
Dim p As Pane
    Set p = QuelPane(Cellule, True)
    If Not p Is Nothing Then
        Place_Curseur = TopLeftCellule(p, Cellule, False)
    End If
    Set p = Nothing
End Function
Private Function TopLeftCellule(ByVal LePane As Pane, ByVal Rng As Range, Optional ByVal DansLaCellule As Boolean = True) As position
Dim cel As Range, cc As Byte, cr As Byte, l As Integer, t As Integer, b As Integer, R As Integer, IniL As Integer, INIT As Integer, IniR As Integer, IniB As Integer
    With LePane
        If Rng.Column = .ScrollColumn Then cc = 0 Else cc = 5
        If Rng.Row = .ScrollRow Then cr = 0 Else cr = 5
        l = .PointsToScreenPixelsX(Rng.Left) - cc: IniL = l
        t = .PointsToScreenPixelsY(Rng.Top) - cr: INIT = t
        R = .PointsToScreenPixelsX(Rng.Offset(1, 1).Left) - cc: IniR = R
        b = .PointsToScreenPixelsY(Rng.Offset(1, 1).Top) - cr: IniB = b
        On Error Resume Next
        Set cel = ActiveWindow.RangeFromPoint(l, t)
        Do Until cel.Left >= Rng.Left
            l = l + 1
            If l > IniL + GARDEFOU Then GoTo BoucleInfinie
            Set cel = ActiveWindow.RangeFromPoint(l, t)
        Loop
        Do Until cel.Top >= Rng.Top
            t = t + 1
            If t > INIT + GARDEFOU Then GoTo BoucleInfinie
            Set cel = ActiveWindow.RangeFromPoint(l, t)
        Loop
        Set cel = Nothing
    End With
    TopLeftCellule.Left = IIf(DansLaCellule, l, l - 1)
    TopLeftCellule.Top = IIf(DansLaCellule, t, t - 1)
    Exit Function
BoucleInfinie:
    MsgBox "Conditions impossibles pour le positionnement du curseur"
End Function

Private Function QuelPane(ByVal t As Range, Optional ByVal ActivationFeuil As Boolean = False) As Pane
Dim LngNbPanes As Long, LngPane As Long
    If ActiveWindow.VisibleRange.Worksheet.Parent.Name = t.Worksheet.Parent.Name Then
        If ActiveWindow.ActiveSheet.Name = t.Worksheet.Name Or ActivationFeuil Then
            t.Worksheet.Activate
            LngNbPanes = ActiveWindow.Panes.Count
            For LngPane = 1 To LngNbPanes
                With ActiveWindow.Panes(LngPane)
                    If Not Intersect(t, .VisibleRange) Is Nothing Then
                        Set QuelPane = ActiveWindow.Panes(LngPane)
                        Exit Function
                    End If
                End With
            Next
        End If
    End If
    Set QuelPane = Nothing
End Function
'---- Déterminer les coordonnées en pixels, par rapport à l'écran, du coin supérieur gauche d'une cellule Excel

'---- Macros MENU et SOUS-MENU
Sub Macro_On_Action(Choix As String)
    ActiveCell = Choix
End Sub
Public Sub Cree_Affich_Menu(Target As Range)
Dim p As position
    Call Suppr_Menu
    Call Creation_Menu
    On Error Resume Next
    p = Place_Curseur(Target.Offset(1, 1))
    Application.CommandBars(NOMPOPUP).ShowPopup p.Left, p.Top
    On Error GoTo 0
End Sub
Private Sub Suppr_Menu()
    On Error Resume Next
    Application.CommandBars(NOMPOPUP).Delete
    On Error GoTo 0
End Sub
Private Sub Creation_Menu()
Dim MenuItem As CommandBarPopup
Dim Plage As Range, R As Range
Dim i As Integer, j As Integer
    With Application.CommandBars.Add(Name:=NOMPOPUP, position:=msoBarPopup, MenuBar:=False, Temporary:=True)
        For i = 2 To 4
            Set MenuItem = .Controls.Add(Type:=msoControlPopup)
            With MenuItem
                .Caption = Worksheets("Listes").Cells(i, 1).Value
                Set R = Worksheets("Listes").Rows(1).Cells.Find(.Caption)
                Set Plage = R.Resize(Worksheets("Listes").Cells(Rows.Count, R.Column).End(xlUp).Row)
                For j = 2 To Plage.Cells.Count
                    With .Controls.Add(Type:=msoControlButton)
                        .Caption = Plage.Cells(j).Value
                        .OnAction = "'" & ThisWorkbook.Name & "'!" & "'Macro_On_Action """ & .Caption & "'"
                    End With
                Next
            End With
        Next
    End With
    Set MenuItem = Nothing
    Set Plage = Nothing
    Set R = Nothing
End Sub
'---- Macros MENU et SOUS-MENU

Dans le module de la feuille concernée :

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Target.Column = 2 Then
            Cree_Affich_Menu Target
        End If
    End If
End Sub

Le fichier exemple (honteusement pompé à Jean-Eric salutations]) :

C'est du lourd!!!!!

Je vais regarder ça et reviens vers vous pour informations

Merci beaucoup

Bonjour PIJAKU,

Dans le classeur que vous avez donné, c'est inscrit dans deux cellules, ma question était de savoir si on pouvait faire ça dans la même cellule.

Click dans cellule, mettre en surbrillance le secteur d'activité (Professionnel/Artisans/Commerce) qui déroule la liste de l'activité secondaire.

ex: ( artisans => plombier)

Bonjour,

c'est inscrit dans deux cellules

Non. Dans une seule, colonne B...

Click dans cellule, mettre en surbrillance le secteur d'activité (Professionnel/Artisans/Commerce) qui déroule la liste de l'activité secondaire.

ex: ( artisans => plombier)

C'est très exactement ce que fait mon code.

Tu as un menu déroulant : "Professionnel/BTP/Commerce" puis des sous-menus...

What Else?

Explique toi mieux ou bien/....

Je dois bugger ça met erreur 13 quand je sélectionne B1 sur Feuille 2!!!

Mais ce doit être moi !!

Quand tu as l'erreur 13, qu'elle ligne est surlignée en jaune sous VBE?

Set MenuItem = .Controls.Add(Type:=msoControlPopup)

Y a t'il une liste de validation de données dans ta cellule de test?

Essaye de cliquer en B1589 par exemple...

Non pas de liste de validation de données dans la cellule test ni en B1589

A tester...

Remplacer :

        For i = 2 To 4
            Set MenuItem = .Controls.Add(Type:=msoControlPopup)
            With MenuItem

par :

        For i = 2 To 4
            On Error Resume Next
            Set MenuItem = .Controls.Add(Type:=msoControlPopup)
            On Error Goto 0
            With MenuItem

Et me dire :

> la ligne qui renvoie une erreur,

> ou alors : ce que ça donne...

Oula...

Mais, que fais tu pour obtenir ça?

Décrit tes gestes... Tous

Copier/coller ?

J'ouvre classeur 3 que tu as mis

j'active les macro quand on me demande

Je clic sur B2

J'obtiens un mess.

je clic "Deboguer"

Je copie dans ton message:

For i = 2 To 4

On Error Resume Next Set MenuItem = .Controls.Add(Type:=msoControlPopup)

On Error Goto 0 With MenuItem

je sélectionne sur Visual basic :

For i = 2 To 4 Set MenuItem = .Controls.Add(Type:=msoControlPopup) With MenuItem

et je colle:

For i = 2 To 4

On Error Resume Next Set MenuItem = .Controls.Add(Type:=msoControlPopup)

On Error Goto 0 With MenuItem

Je clic sur "play" le triangle flèche vers la droite sur VBA.

Et ça, apparait :

je clic sur "DEBOGUER" et :

Voila...

Essaye ceci :

remplacez :

Dim i As Integer, j As Integer
    With Application.CommandBars.Add(Name:=NOMPOPUP, position:=msoBarPopup, MenuBar:=False, Temporary:=True)
        For i = 2 To 4

Par :

Dim i As Integer, j As Integer
Recommence:
    On Error Resume Next
     MsgBox NOMPOPUP
    With Application.CommandBars.Add(Name:=NOMPOPUP, position:=msoBarPopup, MenuBar:=False, Temporary:=True)
    If Err.Number > 0 Then
        Suppr_Menu
        GoTo Recommence
    End If
        For i = 2 To 4

Quand je valide avec "play" ça affiche ça je clic dessus et cette même fenêtre apparait. Je clic une deuxième fois dessus et elle disparait

quand je ferme VBA je clic sur "B1 ou B2 ou B3" ça affiche aussi cette fenetre