Crée un menu en cascade VBA

Bonjour,

Merci pour ton aide mais ce n'est pas que je cherche.

On m'a fait ce fichier. Il est parfait c'est vraiment ce que je recherche mais malheureusment une fois que je colle ma base de donné. Le document fonctionne mais quand je ferme et ouvre mon fichier j'ai un message d'erreur : désolé... nous avons trouvé un problème dans le contenu de (nom du fichier) mais nous pouvons essayer de réparer...."

Savez vous d'ou ca peut venir ?

Merci d'avance

remplace par ceci, c'était presque la ligne juste au-dessus !

dlg = Sheets("Feuil1").Range("B" & Rows.Count).End(xlUp).Row + 1

Bonjour,

explique-moi quelle est la différence avec ceci stp ?

Et si tu mets ta plage en Tableau, tu peux ajouter des segments pour filtrer en 1 clic

eric

Bonjour,

Merci pour votre aide J'ai toujours ce message d'erreur, meme en modifiant avec votre ligne de code.

Eric, Non ce n'est pas un filtre que je souhaite En effet, j'ai besoin de recuperer le fichier à la fin une fois le tableau completer.

Par exemple si je souhaite faire un tableau avec plusieurs personne en fonction des criteres à la suite. Je veux trouver les personnes ayant fait une assurance et ayant une proffesion j'aurais plusieure personne. EnSuite juste en bas je souhaite recuperer une autre assurance avec une autre profession. encore en bas à la suite je souhaite recuperer une autre assurance en fonction de la profession.

C'est pour une etude de :marcher mais du coup j'ai besoin d'avoir toute mes differentes extraction sur le meme tableau.

Je sais pas si je suis clair merci d'avance

C'est ce que fait un filtre avancé https://support.microsoft.com/fr-fr/office/filtrer-%C3%A0-l-aide-de-crit%C3%A8res-avanc%C3%A9s-4c922...

Comment on peut faire compliqué quand il est possible de faire plus simple !! avec des outils standards ...

Private Sub Worksheet_Change(ByVal Target As Range)
    ' condiitons préalables
    If Target.Count > 1 Then Exit Sub
    If Target.Row <= 12 Then Exit Sub

    ' colonne assurance
    If Not Intersect(Target, Columns("A")) Is Nothing Then

        ' effacement à droite et plus bas
        dlg = Range("C" & Rows.Count).End(xlUp).Row
        Rows(Target.Row + 1 & ":" & Application.Max(Target.Row + 1, dlg)).Delete
        Target.Offset(0, 1).Resize(1, 4).ClearContents

        ' mise en place menu déroulant colonne B
        Application.EnableEvents = False
            Call prof
        Application.EnableEvents = True

    ' colonne profession
    ElseIf Not Intersect(Target, Columns("B")) Is Nothing Then

        ' effacement à droite et plus bas
        dlg = Range("C" & Rows.Count).End(xlUp).Row
        Rows(Target.Row + 1 & ":" & Application.Max(Target.Row + 1, dlg)).Delete
        Target.Offset(0, 1).Resize(1, 3).ClearContents

        ' lancement du filtre
        Application.EnableEvents = False
            If Target.Offset(0, -1) <> "" Then filtre
        Application.EnableEvents = True

    End If

End Sub

Sub Supprime()
Dim dlg As Integer
    With Sheets("Feuil1")
        dlg = .Range("C" & Rows.Count).End(xlUp).Row + 1
        .Rows("13:" & dlg).Delete
    End With
    Call assu
End Sub

Sub assu()
Dim data() As Variant
Dim dico As Object
With Sheets("Feuil1")
    dlg = .Range("C" & Rows.Count).End(xlUp).Row + 1
    data = [Assurances].Value
    With .Cells(dlg, 1)
        .ClearContents
        .Validation.Delete
        Set dico = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(data)
            dico(data(i, 1)) = ""
        Next
        If dico.Count > 0 Then
            .Validation.Delete
            .Validation.Add xlValidateList, Formula1:=Join(dico.keys, ",")
        End If
    End With
    With .Cells(dlg, 2)
        .ClearContents
        .Validation.Delete
    End With
End With
End Sub

Sub prof()
Dim data() As Variant
Dim dico As Object
With Sheets("Feuil1")
    dlg = .Range("A" & Rows.Count).End(xlUp).Row
    crit = .Cells(dlg, 1)
    data = Sheets("Feuil2").Cells(1, 1).CurrentRegion.Value
    With .Cells(dlg, 2)
        .ClearContents
        .Validation.Delete
        Set dico = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(data)
            If data(i, 1) = crit Then dico(data(i, 2)) = ""
        Next
        If dico.Count > 0 Then
            .Validation.Delete
            .Validation.Add xlValidateList, Formula1:=Join(dico.keys, ",")
        End If
    End With
End With
End Sub

Sub filtre()
Dim data() As Variant
With Sheets("Feuil1")
    data = Sheets("Feuil2").Cells(1, 1).CurrentRegion.Value
    dlg = .Range("A" & Rows.Count).End(xlUp).Row
    If .Cells(dlg, 2) = "" Then Exit Sub
    ligne = dlg
    For i = 2 To UBound(data)
        If data(i, 1) = .Cells(dlg, 1) And data(i, 2) = .Cells(dlg, 2) Then
            .Cells(ligne, 3) = data(i, 3)
            .Cells(ligne, 4) = data(i, 4)
            .Cells(ligne, 5) = data(i, 5)
            ligne = ligne + 1
        End If
    Next
End With
Call assu
End Sub

J'ai presque honte de cela !

Bonjour eric,

Je ne veux pas passer par un filtre parce que je peux etre amener a selectionner deux fois a la fois les meme profession et la meme assurance, c'est un peu plus compliqué.

Merci d'avance

Donc cela te convient ?

Je suis "con" ... une dernière sans macro ! Merci Eriiic de m'y avoir fait penser

Je lui avais mis sur une feuille mais ça n'avait pas l'air de lui convenir (l'avait-elle vu ? mais je n'avais dupliqué dans un TCD)

Si je comprend son dernier complément, elle pourrais avoir besoin de 2 fois les même données, Habitation Avocat en double par exemple.
eric

Bonjour

Eric, j'ai bien vu ton fichier je l'ai testé mais il convient pas a ce que je souhiate faire mais je vous ai remercier de votre aide.

Steelson, ton fichier me convient parfaitement seulement jai l'impression que le bouton effacer fonctionne pas trés bien. Je souhaiterais suprimer seulement ce qui est en dessous de la ligne 13 avec la ligne incluse mais ca semble prendre case B12. Je ne comptends pas pourquoi. Merci d'avance

Corrigé en ajoutant EnableEvents

Dim data() As Variant
Dim dico As Object
Application.EnableEvents = False
' _________________
Application.EnableEvents = True
End Sub

Bonjour...

puisque c'était fait, un autre exemple

ha la la la la, non non non non, ça va pas du tout !

relis les posts et les différentes versions ... enfin je dis ça je dis rien, mais tu vas fâcher Laura !

il faut que cela commence en ligne 13, que ce soit sur une autre feuille, et qu'elle puisse sélectionner plusieurs fois avec les mêmes critères. Et puis il manque aussi profession.

re...

ha la la la la, non non non non, ça va pas du tout !

relis les posts et les différentes versions ... enfin je dis ça je dis rien, mais tu vas fâcher Laura !

j’ai bien précisé que j’avais fait cela avant toutes les évolutions.

En général, je m’arrange pour donner des exemples pas seulement pour le demandeur mais, aussi, pour les lecteurs qui pourraient être intéressés par le thème.

Suite, après une longue série d'aparté, comme le nombre de valeurs possibles pour la première colonne dépasse 100, ma proposition ne tient plus bien qu'elle répondait exactement à l'ergonomie "imposée".

Oui bien sûr il faut travailler à partir de filtre, mais il faut que Laura accepte ne serait-ce que d'entendre ce terme.

Et faire en sorte que l'extraction puisse être répétée en dessous d'un tableau.

Ton réel besoin tient en quelques lignes

Sub reporter()
Dim bdd As Worksheet, bdt As Worksheet
    Set bdd = Sheets("BdD")
    Set bdt = Sheets("Base de Travail")

    derL = bdt.Cells(Rows.Count, 1).End(xlUp).Row + 1
    bdd.Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=bdt.Cells(derL, 1)
    bdt.Select
End Sub

Sub effacer()
Dim bdt As Worksheet
    Set bdt = Sheets("Base de Travail")

    derL = bdt.Cells(Rows.Count, 1).End(xlUp).Row + 1
    bdt.Rows("13:" & Application.Max(13, derL)).Delete
End Sub

avec

1. tes données en tableau
2. 2 segments sur les 2 premières colonnes telles que proposés par eriiiiiiiic
3. un bouton pour reporter les données filtrées sur ta base de travail, je dis bien FILTREES, à la queue leu leu

Bonjour,

Steelson c'est exactement ce que je cherchais merci beaucoup !! Je l'avoue sur le coup j'etais un peu têtue mais c'est parfait.

Merci mon fichier fonctionne parfaitement !!

Ouf ! tu peux fermer le fil de discussion en cliquant sur V

Merci à eriiiiic de m'avoir rappelé les segments !

Pour effacer l'en-tête

Sub reporter()
Dim bdd As Worksheet, bdt As Worksheet
    Set bdd = Sheets("BdD")
    Set bdt = Sheets("Base de Travail")

    derL = bdt.Cells(Rows.Count, 1).End(xlUp).Row + 1
    bdd.Cells(1, 1).CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Destination:=bdt.Cells(derL, 1)
    bdt.Rows(derL).Delete
    bdt.Select
End Sub

Sub effacer()
Dim bdt As Worksheet
    Set bdt = Sheets("Base de Travail")

    derL = bdt.Cells(Rows.Count, 1).End(xlUp).Row + 1
    bdt.Rows("13:" & Application.Max(13, derL)).Delete
End Sub