Recuperer resultat fitre dans listbox

[KTM]

Bonsoir le Forum
J-aimerais savoir comment paramétrer la listbox de mon USF pour recuperer la resultat de mon filtre appliqué a ma base de données
Ci joint un fichier test
Merci et à plus!!!

 

[BOISGONTIER]

Bonjour,

Private Sub UserForm_Initialize()
  Set Rng = [_FilterDataBase]
  Dim Tmp(): ReDim Tmp(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count)
  For Each c In [_FilterDataBase].Resize(, 1).Offset(1).SpecialCells(xlCellTypeVisible)
     i = i + 1: Tmp(i) = c.Row - Rng.Row + 1
  Next c
  TblBD = Application.Index(Rng, Application.Transpose(Tmp), _
     Application.Transpose(Evaluate("Row(1:" & Rng.Columns.Count & ")")))
  For i = 1 To UBound(TblBD) - 1: TblBD(i, 2) = Format(TblBD(i, 2), "dd/mm/yyyy"): Next i
  Me.ListBox1.List = TblBD
End Sub

Boisgontier

 

[KTM]

Bonjour,

Private Sub UserForm_Initialize()
  Set Rng = [_FilterDataBase]
  Dim Tmp(): ReDim Tmp(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count)
  For Each c In [_FilterDataBase].Resize(, 1).Offset(1).SpecialCells(xlCellTypeVisible)
     i = i + 1: Tmp(i) = c.Row - Rng.Row + 1
  Next c
  TblBD = Application.Index(Rng, Application.Transpose(Tmp), _
     Application.Transpose(Evaluate("Row(1:" & Rng.Columns.Count & ")")))
  For i = 1 To UBound(TblBD) - 1: TblBD(i, 2) = Format(TblBD(i, 2), "dd/mm/yyyy"): Next i
  Me.ListBox1.List = TblBD
End Sub

Boisgontier

Fantastique
Quelques doléances :
J'aimerais que :
- Les entetes de colonne soient affichées dans la listbox en gras
-Dans la colonne Mois , les mois soient affichés comme " Janvier 19, Fevrier 19...….."
-Quelques commentaires pour aider à la compréhension du code
Grand Merci

 

[BOISGONTIER]

Sans feuille intermédiaire:

Dim Rng, TblBD(), NbCol
Private Sub UserForm_Initialize()
  Set Rng = [_FilterDataBase]
  Dim Tmp(): ReDim Tmp(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count)
  For Each c In [_FilterDataBase].Resize(, 1).Offset(1).SpecialCells(xlCellTypeVisible)
     i = i + 1: Tmp(i) = c.Row - Rng.Row + 1
  Next c
  TblBD = Application.Index(Rng, Application.Transpose(Tmp), _
     Application.Transpose(Evaluate("Row(1:" & Rng.Columns.Count & ")")))
  For i = 1 To UBound(TblBD) - 1: TblBD(i, 2) = Format(TblBD(i, 2), "mmmm yy"): Next i
  Me.ListBox1.List = TblBD
  '-- en tête listbox
  NbCol = Rng.Columns.Count
  Me.ListBox1.ColumnCount = NbCol
  EnteteListBox
End Sub

Private Sub TextBox1_Change()
  ColRecherche = 1
  clé = "*" & Me.TextBox1 & "*"
  Dim Tbl()
  For i = LBound(TblBD) To UBound(TblBD) - 1
    If TblBD(i, ColRecherche) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To UBound(TblBD, 2), 1 To n)
        For k = LBound(TblBD, 2) To UBound(TblBD, 2): Tbl(k, n) = TblBD(i, k): Next k
     End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.List = TblBD
End Sub

Sub EnteteListBox()
  x = Me.ListBox1.Left + 8
  y = Me.ListBox1.Top - 12
  For i = 1 To NbCol
    Set Lab = Me.Controls.Add("Forms.Label.1")
    Lab.Caption = Rng.Cells(1, i)
    Lab.Top = y
    Lab.Left = x
    Lab.Font.Bold = True
    x = x + Rng.Columns(i).Width * 1.1
    temp = temp & Rng.Columns(i).Width * 1.1 & ";"
  Next
  temp = Left(temp, Len(temp) - 1)
  On Error Resume Next
  Me.ListBox1.ColumnWidths = temp
End Sub

Les tableaux

Boisgontier

 

[job75]

Bonjour KTM, JB, le forum,

Private Sub UserForm_Initialize()
With Sheets("Liste")
    .Cells.Delete
    [A1].CurrentRegion.Copy .[A1]
    .Rows(1).Delete
    If .[A1] <> "" Then ListBox1.RowSource = .[A1].CurrentRegion.Address(External:=True)
End With
End Sub

Private Sub TextBox1_Change()
Dim ColRecherche%, clé$
ColRecherche = 1
clé = "*" & Me.TextBox1 & "*"
[A1].CurrentRegion.AutoFilter ColRecherche, clé
ListBox1.RowSource = ""
UserForm_Initialize
End Sub

Les en-têtes de colonnes de la ListBox sont dans des Labels.

A+

 

[KTM]

Sans feuille intermédiaire:

Dim Rng, TblBD(), NbCol
Private Sub UserForm_Initialize()
  Set Rng = [_FilterDataBase]
  Dim Tmp(): ReDim Tmp(1 To [_FilterDataBase].Resize(, 1).SpecialCells(xlCellTypeVisible).Count)
  For Each c In [_FilterDataBase].Resize(, 1).Offset(1).SpecialCells(xlCellTypeVisible)
     i = i + 1: Tmp(i) = c.Row - Rng.Row + 1
  Next c
  TblBD = Application.Index(Rng, Application.Transpose(Tmp), _
     Application.Transpose(Evaluate("Row(1:" & Rng.Columns.Count & ")")))
  For i = 1 To UBound(TblBD) - 1: TblBD(i, 2) = Format(TblBD(i, 2), "mmmm yy"): Next i
  Me.ListBox1.List = TblBD
  '-- en tête listbox
  NbCol = Rng.Columns.Count
  Me.ListBox1.ColumnCount = NbCol
  EnteteListBox
End Sub

Private Sub TextBox1_Change()
  ColRecherche = 1
  clé = "*" & Me.TextBox1 & "*"
  Dim Tbl()
  For i = LBound(TblBD) To UBound(TblBD) - 1
    If TblBD(i, ColRecherche) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To UBound(TblBD, 2), 1 To n)
        For k = LBound(TblBD, 2) To UBound(TblBD, 2): Tbl(k, n) = TblBD(i, k): Next k
     End If
  Next i
  If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.List = TblBD
End Sub

Sub EnteteListBox()
  x = Me.ListBox1.Left + 8
  y = Me.ListBox1.Top - 12
  For i = 1 To NbCol
    Set Lab = Me.Controls.Add("Forms.Label.1")
    Lab.Caption = Rng.Cells(1, i)
    Lab.Top = y
    Lab.Left = x
    Lab.Font.Bold = True
    x = x + Rng.Columns(i).Width * 1.1
    temp = temp & Rng.Columns(i).Width * 1.1 & ";"
  Next
  temp = Left(temp, Len(temp) - 1)
  On Error Resume Next
  Me.ListBox1.ColumnWidths = temp
End Sub

Boisgontier

C'est super Merci
ça marche
Mais pour moins calé comme moi c'est difficile à déchiffré !

 

[KTM]

Bonjour KTM, JB, le forum,

Private Sub UserForm_Initialize()
With Sheets("Liste")
    .Cells.Delete
    [A1].CurrentRegion.Copy .[A1]
    .Rows(1).Delete
    If .[A1] <> "" Then ListBox1.RowSource = .[A1].CurrentRegion.Address(External:=True)
End With
End Sub

Private Sub TextBox1_Change()
Dim ColRecherche%, clé$
ColRecherche = 1
clé = "*" & Me.TextBox1 & "*"
[A1].CurrentRegion.AutoFilter ColRecherche, clé
ListBox1.RowSource = ""
UserForm_Initialize
End Sub

Les en-têtes de colonnes de la ListBox sont dans des Labels.

A+

Sacré job75!!!!!!!
Y'a rien à dire
C'est court-Precis-Facile à comprendre-ingénieux simplement génial! Merci à vous tous.