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
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
Dernière édition:
