XL 2019 filtre avancé VBA

youpi457032

XLDnaute Occasionnel
Bonjour,
je possède une macro pour filtrer et sous filtrer sur plusieurs colonnes
J'aimerai adapter mon code pour que le premier critère ne filtre par sur une seule colonne mais plusieurs colonnes qui regroupent le même type de données.
Exemple dans les colonnes 13 à 17 j'ai des données identiques. J'aimerai que le filtre fasse le travail sur l'ensemble des colonnes 13 à 17 et non uniquement la colonne 13.
Mon dchoisis1 doit faire le travail sur le bloc de colonne 13 à 17. Quelqu'un peut il m'aider ?
Voici mon code
Code:
 :
Option Compare Text
Dim TblBD(), dchoisis1, dchoisis2, dchoisis3, nomtableau, NbCol

Private Sub ListBox1_Click()

End Sub

Private Sub UserForm_Initialize()
 
  nomtableau = "tableau1"
  NbCol = Range(nomtableau).Columns.Count
  TblBD = Range(nomtableau).Value
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To Range(nomtableau).Rows.Count
    [COLOR=rgb(250, 197, 28)]tmp = TblBD(i, 13): d(tmp) = ""  [/COLOR][COLOR=rgb(97, 189, 109)]' je pense que mon souci démarre ici
  Next i[/COLOR]
  Me.OptionsGenre.MultiSelect = fmMultiSelectMulti
  Me.OptionsGenre.ListStyle = 1 'frmliststyleoption
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.OptionsGenre.List = Tbl
  '--
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To Range(nomtableau).Rows.Count
    tmp = TblBD(i, 18): d(tmp) = ""
  Next i
  Me.OptionsArtiste.MultiSelect = fmMultiSelectMulti
  Me.OptionsArtiste.ListStyle = 1 'frmliststyleoption
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.OptionsArtiste.List = Tbl
  '---
   Set d = CreateObject("scripting.dictionary")
  For i = 1 To Range(nomtableau).Rows.Count
    tmp = TblBD(i, 19): d(tmp) = ""
  Next i
  Me.OptionAlbum.MultiSelect = fmMultiSelectMulti
  Me.OptionAlbum.ListStyle = 1 'frmliststyleoption
  Tbl = d.keys
  Tri Tbl, LBound(Tbl), UBound(Tbl)
  Me.OptionAlbum.List = Tbl
  '--
  Me.ListBox1.ColumnCount = Range(nomtableau).Columns.Count + 1
  Me.ListBox1.List = TblBD
  EnteteListBox
End Sub
Private Sub OptionsGenre_change()
  Affiche
End Sub
Private Sub OptionsArtiste_change()
  Affiche
End Sub
Private Sub OptionAlbum_change()
  Affiche
End Sub
Sub Affiche()
  Set dchoisis1 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionsGenre.ListCount - 1
    If Me.OptionsGenre.Selected(i) Then dchoisis1(Me.OptionsGenre.List(i, 0)) = ""
  Next i
  Set dchoisis2 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionsArtiste.ListCount - 1
    If Me.OptionsArtiste.Selected(i) Then dchoisis2(Me.OptionsArtiste.List(i, 0)) = ""
  Next i
     Set dchoisis3 = CreateObject("Scripting.Dictionary")
  For i = 0 To Me.OptionAlbum.ListCount - 1
    If Me.OptionAlbum.Selected(i) Then dchoisis3(Me.OptionAlbum.List(i, 0)) = ""
  Next i
  Dim Tbl2(): n = 0: Ncol = UBound(TblBD, 2)
  For i = 1 To UBound(TblBD)
    tmp = TblBD(i, 13): tmp2 = TblBD(i, 2): tmp3 = TblBD(i, 3)
    If (dchoisis1.exists(tmp) Or dchoisis1.Count = 0) And (dchoisis2.exists(tmp2) Or dchoisis2.Count = 0) And (dchoisis3.exists(tmp3) Or dchoisis3.Count = 0) Then
        n = n + 1: ReDim Preserve Tbl2(1 To Ncol, 1 To n)
        For k = 1 To Ncol: Tbl2(k, n) = TblBD(i, k): Next k
    End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl2 Else Me.ListBox1.Clear
  Me.LabelLigne.Caption = n & " élèves"
End Sub
Sub Tri(a, gauc, droi) ' Quick sort
 ref = CStr(a((gauc + droi) \ 2))
 g = gauc: d = droi
 Do
  Do While CStr(a(g)) < ref: g = g + 1: Loop
  Do While ref < CStr(a(d)): d = d - 1: Loop
  If g <= d Then
    temp = a(g): a(g) = a(d): a(d) = temp
    g = g + 1: d = d - 1
  End If
 Loop While g <= d
 If g < droi Then Call Tri(a, g, droi)
 If gauc < d Then Call Tri(a, gauc, d)
End Sub

Sub EnteteListBox()
   x = Me.ListBox1.Left + 8
   Y = Me.ListBox1.Top - 15
   For c = 1 To NbCol
       Set Lab = Me.Controls.Add("Forms.Label.1")
       Lab.Caption = Range(nomtableau).Offset(-1).Item(1, c)
       Lab.ForeColor = vbBlack
       Lab.Top = Y
       Lab.Left = x
       Lab.Height = 15
       Lab.Width = Range(nomtableau).Columns(c).Width * 1#
       x = x + Range(nomtableau).Columns(c).Width * 1
       tempcol = tempcol & Range(nomtableau).Columns(c).Width * 1# & ";"
   Next c
   tempcol = tempcol
   On Error Resume Next
   Me.ListBox1.ColumnWidths = tempcol
   On Error GoTo 0
End Sub

[fin de code]
Merci d'avance
 

Pièces jointes

  • filtre multicritères.xlsm
    603.5 KB · Affichages: 10
Dernière édition:

youpi457032

XLDnaute Occasionnel
Au lieu d'un code improbable expliquez en bon français comment vous voulez filtrer.
bon....
je souhaite filtrer sur plusieurs colonnes pour affiner les criteres les uns apres les autres...
filter de plus en plus finement...
Je gere une association de danse... je souhaite faire apparaitre dans ma liste box tous les elèves qui ont pris les cours selectionnés par le filtre, pour la plage M (colonne 13 ) à Q(colonne 17 incluse).
Ma macro fonctionne tres bien, mais mais que pour la ligne 13, moi il me faut integrer aussi les colonnes 14 à 17... sinon il va me manquer des résultats.... Ce que je souhaite c'est avoir le bout de code macro qui me manque pour filter sur les colonnes 13 à 17 et pas uniquement la 13....
Sinon tout le reste fonctionne bien....
 

Pièces jointes

  • filtre multicritèressource.xlsm
    603.9 KB · Affichages: 8

youpi457032

XLDnaute Occasionnel
bon....
je souhaite filtrer sur plusieurs colonnes pour affiner les criteres les uns apres les autres...
filter de plus en plus finement...
Je gere une association de danse... je souhaite faire apparaitre dans ma liste box tous les elèves qui ont pris les cours selectionnés par le filtre, pour la plage M (colonne 13 ) à Q(colonne 17 incluse).
Ma macro fonctionne tres bien, mais mais que pour la ligne 13, moi il me faut integrer aussi les colonnes 14 à 17... sinon il va me manquer des résultats.... Ce que je souhaite c'est avoir le bout de code macro qui me manque pour filter sur les colonnes 13 à 17 et pas uniquement la 13....
Sinon tout le reste fonctionne bien....
Bonsoir,
comment je l'ecris ??
 

job75

XLDnaute Barbatruc
Re, salut ChTi160,

Je n'ai pas essayé de comprendre ce que vous voulez faire avec votre UserForm et ses ListBox.

En tout cas je n'en vois pas l'utilité pour filtrer.

Voyez le fichier joint et ces 2 macros :
VB:
Sub Filtrer()
Dim col, i%, x$, critere$
col = Array("M", "N", "O", "P", "Q")
For i = 0 To UBound(col)
    x = Application.InputBox("Critere colonne " & col(i), Type:=2)
    If x <> "" Then critere = critere & ",ISNUMBER(SEARCH(""" & x & """," & col(i) & "3))"
Next
If critere = "" Then Exit Sub
With Sheets("BD") 'la ligne 1 doit rester vide
    .[S3] = "=AND(" & Mid(critere, 2) & ")" 'formule du critere
    .[A2].CurrentRegion.AdvancedFilter xlFilterInPlace, .[S2:S3]
    .[S3] = ""
End With
End Sub

Sub RAZ()
With Sheets("BD")
    If .FilterMode Then .ShowAllData
End With
End Sub
A+
 

Pièces jointes

  • filtre multicritèressource(1).xlsm
    47 KB · Affichages: 7

youpi457032

XLDnaute Occasionnel
Re, salut ChTi160,

Je n'ai pas essayé de comprendre ce que vous voulez faire avec votre UserForm et ses ListBox.

En tout cas je n'en vois pas l'utilité pour filtrer.

Voyez le fichier joint et ces 2 macros :
VB:
Sub Filtrer()
Dim col, i%, x$, critere$
col = Array("M", "N", "O", "P", "Q")
For i = 0 To UBound(col)
    x = Application.InputBox("Critere colonne " & col(i), Type:=2)
    If x <> "" Then critere = critere & ",ISNUMBER(SEARCH(""" & x & """," & col(i) & "3))"
Next
If critere = "" Then Exit Sub
With Sheets("BD") 'la ligne 1 doit rester vide
    .[S3] = "=AND(" & Mid(critere, 2) & ")" 'formule du critere
    .[A2].CurrentRegion.AdvancedFilter xlFilterInPlace, .[S2:S3]
    .[S3] = ""
End With
End Sub

Sub RAZ()
With Sheets("BD")
    If .FilterMode Then .ShowAllData
End With
End Sub
A+
Merci d'avoir pris du temps....
Maic ce n'est pas ce type de fonction de filtrage que je recherche...
Je souhaite garder mes resultats dans mon userform (sous formulaire)...
Je souhaite juste que le critère " choix du cours de danse" filtre sur les colonnes M à Q en même temps, et pas M uniquement.... l'idée finale étant pour tout vous avouer faire du mailing ciblé... en exportant les resultats du sous formulaires vers une feuille resutlat_filtre, récuperer les adresses mail... et tout exporter dans outlook ( cette derniere partie est dejà fonctionnelle)...
Merci
 

youpi457032

XLDnaute Occasionnel
Re
dommage que tu n'est pas mis la solution a ton problème (partage)
moi j'avais travaillé la dessus!
dommage !
jean marie
je te joins mon fichier modifié des que je l'ai anonymisé....
je te remerercie d'avoir pris du temps
j'aurai encore besoin d'aide je pense....
comme par exemple associé en Vba une liste de cours à un in nom d'intervenant et l'ecrire ligne par ligne dans 5 colonnes différentes....
ex : choix du cours UN en colonne M = Bachata, ecrire en colonne "s" le nom de l'intervenant "Chou",
pour la même cellule si le cours corrsepond à un autre intervenant faire correspondre le bon nom d'intervenant...
Tu penses que tu pourrais travailler là-dessus?
je te donne le tableau :
colonne M : cours 1 (ex salsa, bachata, rock.....etc ) ----> colonne S ---Nom de l'intervenant ( parmi une liste d'intervenant : CHAQUE intervenant ayant sa liste de cours ! )
Colonne N : cours 2 (ex salsa, bachata, rock.....etc ) ----> colonne T ---Nom de l'intervenant ( parmi une liste d'intervenant)
Colonne O : cours 3 (ex salsa, bachata, rock.....etc ) ----> colonne U ---Nom de l'intervenant ( parmi une liste d'intervenant)
Colonne P : cours 4 (ex salsa, bachata, rock.....etc ) ----> colonne V ---Nom de l'intervenant ( parmi une liste d'intervenant)
Colonne Q : cours 5 ((ex salsa, bachata, rock.....etc ) ----> colonne W ---Nom de l'intervenant ( parmi une liste d'intervenant)
L'idée étant de pouvoir filter par intervenant.... (toujours selon le même principe)
 

Pièces jointes

  • filtre multicritères travail.xlsm
    612.2 KB · Affichages: 12
Dernière édition:

Discussions similaires

Réponses
4
Affichages
165
Réponses
12
Affichages
225

Statistiques des forums

Discussions
311 733
Messages
2 082 011
Membres
101 866
dernier inscrit
XFPRO