Extraction de base de données avec critères et cellules Multi informations

[Laurinette]

Bonjour et bonne année à tout le monde !

Je souhaiterais une aide de votre part

En fait, j'aimerais, depuis une feuille différente de la base de données, extraire des lignes suivant 2 critères:

• Le premier critère serait le loisir, le loisir est renseigné dans une cellule où il peut y avoir plusieurs loisirs (la difficulté est surtout là).
• Le deuxième serait le sexe de la personne par exemple.

Le premier critère serait présélectionné dans une liste déroulante par sa présence à la cellule A1 de la dite feuille.
Je vous joints un fichier Excel qui sera bien plus parlant qu'un long texte.

Je vous remercie par avance de l'aide que vous pourrez m'apporter.
Laure

 

[Dranreb]

Re : Extraction de base de données avec critères et cellules Multi informations

Oui, il suffit de remplacer Feuil2 par ActiveSheet.

Il ne reste plus qu'à ajouter cette procédure :

Private Sub CommandButton1_Click()
Dim TE(), LE&, TS(), LS&, C&, N
TE = CL.PlgTablo.Resize(, 6).Value
ReDim TS(1 To UBound(TLgn), 1 To 8)
For N = 1 To UBound(TLgn)
   If ListBox1.Selected(N - 1) Then
      LS = LS + 1: LE = TLgn(N)
      For C = 1 To 4: TS(LS, C) = TE(LE, C): Next C
      For C = 7 To 8: TS(LS, C) = TE(LE, C - 2): Next C
      End If: Next N
If LS = 0 Then Beep: Exit Sub
ActiveSheet.[B1010].End(xlUp).Offset(1).Resize(LS, 8).Value = TS
FiltrerDéjàInscrits
End Sub

 

[Laurinette]

Re : Extraction de base de données avec critères et cellules Multi informations

Oui, il suffit de remplacer Feuil2 par ActiveSheet.

Il ne reste plus qu'à ajouter cette procédure :

Private Sub CommandButton1_Click()
Dim TE(), LE&, TS(), LS&, C&, N
TE = CL.PlgTablo.Resize(, 6).Value
ReDim TS(1 To UBound(TLgn), 1 To 8)
For N = 1 To UBound(TLgn)
   If ListBox1.Selected(N - 1) Then
      LS = LS + 1: LE = TLgn(N)
      For C = 1 To 4: TS(LS, C) = TE(LE, C): Next C
      For C = 7 To 8: TS(LS, C) = TE(LE, C - 2): Next C
      End If: Next N
If LS = 0 Then Beep: Exit Sub
ActiveSheet.[B1010].End(xlUp).Offset(1).Resize(LS, 8).Value = TS
FiltrerDéjàInscrits
End Sub

Je te remercie grandement Dranreb !

J'ai dû enlever "FiltrerDéjàInscrits" car il y avait une erreur. A quoi cela sert-il?

Je vais me pencher sur la compréhension du code dès demain.

Passe une bonne fin de soirée.
Laure

 

[Dranreb]

Re : Extraction de base de données avec critères et cellules Multi informations

Ben ça sert à éviter que les gens qui viennent d'être ajoutés puissent toujours l'être !
Heu… C'est bien déjà comme ça dans ma dernière version jointe ? Sinon corrigez :
Le code de la Sub FiltrerDéjàInscrits était initialement dans la UserForm_Activate.
Mais je me suis aperçu, justement, que j'aurais à le refaire, alors je l'ai séparé en deux morceaux :

Private Sub UserForm_Activate()
ComboBox_Loisir.Text = ActiveSheet.[A1].Value
FiltrerDéjàInscrits
End Sub
'

Private Sub FiltrerDéjàInscrits()
Dim TDéjà(1 To 999) As Boolean, TE(), LE&, TS(), LS&, C&
ComboBox_Loisir.Text = ActiveSheet.[A1].Value
TE = PlgUti(ActiveSheet.[B4])
For LE = 2 To UBound(TE): TDéjà(TE(LE, 1)) = True: Next LE
TE = CL.PlgTablo.Columns(1).Value
ReDim TLgn(1 To 999)
For LE = 1 To UBound(TE)
   If Not TDéjà(TE(LE, 1)) Then LS = LS + 1: TLgn(LS) = LE
   Next LE
ReDim Preserve TLgn(1 To LS)
CL.FiltrerLignes TLgn
End Sub

 

[BOISGONTIER]

Re : Extraction de base de données avec critères et cellules Multi informations

Bonjour,

Voir PJ

Dim f, TblBd
Private Sub UserForm_Initialize()
  Set f = Sheets("base de données")
  Set d = CreateObject("Scripting.Dictionary")
  TblBd = f.Range("a2:f" & f.[A65000].End(xlUp).Row)
  d("*") = ""
  For i = LBound(TblBd) To UBound(TblBd)
    a = Split(TblBd(i, 6), ";")
    For Each c In a: d(c) = "": Next c
  Next i
  Me.ComboBox1.List = d.keys
  Me.ComboBox2.List = Array("*", "F", "M")
  Me.ComboBox1 = ActiveSheet.[A1]
  ComboBox1_click
End Sub

Private Sub ComboBox1_click()
 ListBox1.Clear
 j = 0
 For i = LBound(TblBd) To UBound(TblBd)
   If (InStr(TblBd(i, 6), ComboBox1) > 0 And TblBd(i, 5) Like ComboBox2) _
     Or (Me.ComboBox1 = "*" And TblBd(i, 5) Like ComboBox2) Then
     Me.ListBox1.AddItem
     For k = 1 To 6
         ListBox1.List(j, k - 1) = TblBd(i, k)
     Next k
     j = j + 1
   End If
  Next i
End Sub

Private Sub ComboBox2_Click()
   ComboBox1_click
End Sub

Private Sub b_ajout_Click()
 For i = 0 To Me.ListBox1.ListCount - 1
     If Me.ListBox1.Selected(i) = True Then
       ref = Me.ListBox1.List(i, 0)
       Set result = [b2:b1000].Find(what:=ref, lookat:=xlWhole)
       If result Is Nothing Then
         ligne = [b65000].End(xlUp).Row + 1
         For k = 0 To 5
           ActiveSheet.Cells(ligne, k + 2) = Me.ListBox1.List(i, k)
         Next k
       End If
     End If
  Next i
End Sub

JB

 

[Dranreb]

Re : Extraction de base de données avec critères et cellules Multi informations

Bonjour.
Je joins le classeur à jour des dernières améliorations.

 

[Laurinette]

Re : Extraction de base de données avec critères et cellules Multi informations

Bonjour Dranreb, BOISGONTIER et le forum,
Pour commencer je vous remercie car chacune des solutions est fonctionnelle.

Dranreb, sur ta dernière pièce jointe, j'ai testé les limites du formulaire en allant jusqu'à l'ajout du dernier contact.
Est-il possible d'éviter le message d'erreur :


Merci d'avance

 

[Dranreb]

Re : Extraction de base de données avec critères et cellules Multi informations

Bonjour.

Oui, ajoutez ça devant le Redim Preserve :

If LS = 0 Then
   Me.Hide
   MsgBox "Il n'y a plus personne à ajouter.", vbInformation, Me.Caption
   Unload Me: Exit Sub
   End If