Partage d'un fichier VBA contenant un UserForm

C'est fait. Cela à l'air de fonctionné car je n'ai pas de message d'erreur

Ok on passe au suivant

1. Au dessus de tous les codes, mettez ces deux instructions

Option Compare Text
Dim col As Byte

2. Ajoutez ce code qui sera exécuté au changement de la combobox

Private Sub ComboBox1_Change()
col = ComboBox1.ListIndex + 2
TextBox1 = vbNullString
Call init
End Sub

3. Ajoutez ce code pour la textbox1 dans laquelle vous allez entrer votre recherche

Private Sub TextBox1_AfterUpDate()
If ComboBox1.Value = vbNullString Then
    MsgBox ("Veuillez choisir un critère de recherche dans la liste déroulante"), vbInformation, "Information"
    TextBox1.Value = vbNullString
End If
End Sub

4. Ajoutez ce code qui sera exécuté au click du bouton Rechercher

Private Sub btnRechercher_Click()
Dim tablo()
Dim n As Integer, i As Integer
Dim k As Byte
Dim lig

lstDossier.Clear

If TextBox1 = vbNullString Then Call init: Exit Sub

With ThisWorkbook.Worksheets("Base").ListObjects(1) '.ListColumns(3)

    n = .DataBodyRange.Rows.Count
    ReDim tablo(1 To n, 1 To .DataBodyRange.Columns.Count)
    lig = 0

    For i = 1 To n
        If .DataBodyRange(i, col).Value Like "*" & TextBox1.Value & "*" Then
            lig = lig + 1
            For k = 1 To .DataBodyRange.Columns.Count
                tablo(lig, k) = .DataBodyRange(i, k).Value 'Cells(i + 1, k)
            Next k
        End If
    Next i

    lstDossier.List = tablo()
End With

'supprimer les lignes vides dans listbox
For i = lstDossier.ListCount - 1 To 0 Step -1
    If lstDossier.List(i, col) = "" Then lstDossier.RemoveItem (i)
Next i

txtTotal = lig
End sub

Faites un test et dites-moi

Rem : à quoi va vous servir le code Private Sub btnAjouter_Click() ?

Tout fonctionne parfaitement à part le fait que les critères (nom; prénom; age ...) ne s'affiche pas en haut de la ListBox. Si vous avez une solution ...?

Le bouton ajouter sert à renvoyé vers la fin de la base pour ajouter un nouveau dossier.

Tout fonctionne parfaitement à part le fait que les critères (nom; prénom; age ...) ne s'affiche pas en haut de la ListBox. Si vous avez une solution ...?

Deux solutions possibles :
- Ajout d'un label en dehors de la listbox pour chaque colonne
ou
- Ajout d'une seconde listbox juste au dessus de la listbox1 et de même dimension en largeur. Cette listbox ne servira que pour les titres. Les titres seront chargés à l'ouverture de l'USF avec le code initialize que je peux vous adapter si vous me donner le nom de la listbox
Cela donnerait ceci.
Votre avis ?

Le bouton ajouter sert à renvoyé vers la fin de la base pour ajouter un nouveau dossier.

Ok. Le code à tester comme ceci :

Sub AjouterDossier()
Dim dlg As Integer
With Feuil2
    .Select
    With .ListObjects(1)
        dlg = .ListRows.Count + .HeaderRowRange.Row
        .DataBodyRange(dlg, 1).Select
    End With
End With
End sub

Je vais ajouter des labels, je pense que cela rendra l'USF plus esthétique.

J'ai une dernière demande:

Savez vous comment je pourrais figer l'écran de la première feuille (Accueil) de façon définitive. J'ai testé la fonction ScrollArea mais celle-ci se désactive après la fermeture du classeur

Je vais ajouter des labels, je pense que cela rendra l'USF plus esthétique.

Ok. A ce sujet dans la sub initialize, vous pouvez ajouter cette ligne juste en dessous du CALL INIT

lstDossier.ColumnWidths = "50;150;100;45;75;25;75;60;50;100"

Cela permettre de dimensionner chaque colonne et de bien placer vos labels.
On pourrait d'ailleurs les compléter aussi par le code si vous voulez. Dans ce cas le mieux est de les nommer label1, label2, label3....

Savez vous comment je pourrais figer l'écran de la première feuille (Accueil) de façon définitive. J'ai testé la fonction ScrollArea mais celle-ci se désactive après la fermeture du classeur

C'est faisable mais vous ne voulez que sur la feuille Accueil je suppose ?

Je vois aussi que vous avez placé une protection mais le code est au mauvais endroit. cela ne concerne que la feuille Accueil je suppose ?

C'est exactement le code qu'il me fallait le ColumnWidths, merci beaucoup.

Cela concerne uniquement la feuille Accueil. J'aimerais la figer jusqu'à L37

1. Pour les labels vous les complétez sans code ?

2.

Cela concerne uniquement la feuille Accueil. J'aimerais la figer jusqu'à L37

Est-ce vous voulez voir les entetes de colonnes et lignes ainsi que les scroll vertical et horizontal sur la feuille accueil ?

3. Quid de la protection ?

1. Je veux bien voir ce que cela donne. D'ailleurs j'aimerais savoir si on peut mettre les labels à l'intérieur de la ListBox (car j'ai beau essayé de les mettres au premier-plan, cela ne fonctionne pas).

2. Non, j'aimerais que la feuille n'affiche que le contenu et qu'on ne puisse pas scroller dessus.

3. La protection avait était mise pour que les éléments de la feuille ne puissent pas êtres modifier par les autres utilisateurs et voir si tout fonctionnait correctement au niveau du USF et filtres. Avec les filtres cela ne fonctionnait pas mais avec votre méthode si. Donc n'en tenait pas compte.

D'ailleurs j'aimerais savoir si on peut mettre les labels à l'intérieur de la ListBox (car j'ai beau essayé de les mettres au premier-plan, cela ne fonctionne pas).

A l'intérieur non ce n'est pas possible. Comme la vue ci-dessous :

Dites moi si Ok pour faire le code afin de les remplir

2. Non, j'aimerais que la feuille n'affiche que le contenu et qu'on ne puisse pas scroller dessus.

Ok alors mettez ceci dans THISWORKBOOK
Ensuite je ne mettrais pas de la couleur grise sur toutes les lignes et colonnes mais uniquement dans la vue que vous voulez voir.

Private Sub Workbook_Open()
With Feuil1
    .Activate
    .ScrollArea = .UsedRange.Address
    '.ScrollArea = .Cells.Address 'reactiver acces total a la feuille
End With
End Sub

3. La protection .....Avec les filtres cela ne fonctionnait pas mais avec votre méthode si. Donc n'en tenait pas compte.

Donc la macro Sub MacroavecfeuilleProtect() est à supprimer

Bonjour Dan,

1. Dans ce cas, savez vous comment retirer la ligne qui sépare la liste et les labels ?

2. J'ai copié le code dans thisworkbook, bizarrement cela ne fonctionne pas. J'ai aucun message d'erreur mais je peux scroll sur la feuille.

3. Question supplémentaire: quelle partie du code dois-je modifier pour afficher uniquement certains critères dans la listbox à la place de tout le tableau (exemple: nom;prénom;sexe)?

Encore merci

Bonjour

1. Dans ce cas, savez vous comment retirer la ligne qui sépare la liste et les labels ?

Comment avez-vous fait cela ?
je pense que vous n'avez pas ajouté les labels comme je vous l'ai montré
Mettez simplement les labels comme montré dans mon post précédent. Nul besoin de mettre le nom de votre rubrique. Ce sera fait par le code
Vous devez avoir la mention Label1, Label2, ....jusque Label11. Les propriétés nom et caption du label doivent être identiques

2. J'ai copié le code dans thisworkbook, bizarrement cela ne fonctionne pas. J'ai aucun message d'erreur mais je peux scroll sur la feuille.

Dans votre fichier posté, vous avez mis une mention à la ligne 35 (Merci de ne pas modifier les noms des feuilles de calcul)
Vous l'avez supprimée ? Si oui, c'est normal votre souci.

3. Question supplémentaire: quelle partie du code dois-je modifier pour afficher uniquement certains critères dans la listbox à la place de tout le tableau (exemple: nom;prénom;sexe)?

Je n'ai pas compris la question. Là le code tient compte de la valeur choisie dans la combo et de ce que vous mettez dans la textbox

1. J'ai juste ajouter les labels et ajuster selon la longueur des colonnes en bas manuellement. J'ai refait comme sur votre exemple finalement

2. En effet! Ca marche maintenant. Merci !

3. Je veux, en effet, afficher uniquement les noms, prénoms, sexe et date de naissance dans la liste box sans tenir compte des autres critères qui sont moins importants

1. J'ai juste ajouter les labels et ajuster selon la longueur des colonnes en bas manuellement. J'ai refait comme sur votre exemple finalement

Ok pour l'ajout des labels.
Remplacez le code Initiaize par celui ci-dessous:

Private Sub userform_initialize()
Dim lbl()
Dim i as byte

Call Trier
Call init

lstDossier.ColumnWidths = "50;150;100;45;75;25;75;60;50;100;40" 'dimension de chaque colonne
lbl = Array("50", "150", "100", "45", "75", "25", "75", "60", "50", "100", "40")'dimension de chaque label

For i = 0 To UBound(lbl)
    With Controls("Label" & i + 1)
        .Width = lbl(i)
        .Caption = Feuil2.ListObjects(1).HeaderRowRange(i + 1).Value
        If i = 0 Then
            .Left = 30
        Else:
            .Left = Controls("Label" & i).Left + Controls("Label" & i).Width
        End If
    End With
Next i
ComboBox1.List = WorksheetFunction.Transpose(Feuil2.Range("B1:G1"))
End with

Après vous pouvez aussi enlever les bordures et mettre une couleur de fond à vos labels. Le code ne prévoit rien à ce sujet

Faites un test

Edit : remplacé deux lignes dans le code

Le code fonctionne parfaitement. Merci!

Si vous avez une solution pour supprimer la ligne vide entre les labels et la liste, je serais preneur

J'ai fini par trouver la solution. Il fallait juste supprimer la listbox et refaire une autre.

Un très grand merci à vous pour votre aide. C'est vraiment dingue d'avoir un tel niveau en codage.

En vous souhaitant une belle journée, bien cordialement,

Bah non nul besoin de refaire la listbox.

Modifiez simplement le code de recherche comme ci-dessous. Comme cela vous conservez toujours la lise complète lorsque vous n'effectuez pas de recherche

Private Sub btnRechercher_Click()
Dim tablo()
Dim nblig As Integer, i As Integer
Dim k As Byte, nbcol As Byte
Dim lig

lstDossier.Clear

If TextBox1 = vbNullString Then Call init: Exit Sub

With ThisWorkbook.Worksheets("Base").ListObjects(1)

    nblig = .DataBodyRange.Rows.Count
    nbcol = .DataBodyRange.Columns.Count - 6

    ReDim tablo(1 To nblig, 1 To nbcol)
    lig = 0

    For i = 1 To nblig
        If .DataBodyRange(i, col).Value Like "*" & TextBox1.Value & "*" Then
            lig = lig + 1
            For k = 1 To nbcol
                tablo(lig, k) = .DataBodyRange(i, k).Value
            Next k
        End If
    Next i

End With
With lstDossier
    .ColumnWidths = "50;150;100;45;75" 'dimension des colonnes
    .List = tablo()

    'supprimer les lignes vides dans listbox
    For i = .ListCount - 1 To 0 Step -1
        If .List(i, col) = "" Then .RemoveItem (i)
    Next i
End With

txtTotal = lig
End sub

Faites un test

Si vous avez une solution pour supprimer la ligne vide entre les labels et la liste, je serais preneur

Allez dans votre USF et cliquez sur la Listbox
Allez dans les propriétés de la listbox et mettez la propriété "ColumnHeads" à False (elle est certainement à TRUE)