XL 2019 filtre avancé VBA

[youpi457032]

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

 :
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

 

[ChTi160]

Re
non je ne pense pas !
jean marie

 

[ChTi160]

Bonjour Youpi457032
Bonjour le Fil ,le Forum
je n'ai pas bien compris ce que tu as trouvé pour résoudre ton problème #13
mais bon !
ce que j'ai fait avec ce que j'ai compris de cette Histoire de "nom d'intervenant"
Bonne journée
jean marie