XL 2019 Recherche dans les sous dossiers d'un répertoire via VBA sur excel

[chaval]

Bonsoir,
En pièce jointe, le fichier excel. Le code VBA ne permet pas de faire une recherche dans les sous dossiers du répertoire.
Sauriez-vous comment modifier le code pour permettre d'effectuer une recherche lors de l'utilisation de l'userform dans des sous dossiers, svp?
Je serai reconnaissante de toute aide apportée ! 🙂

 

[Dranreb]

Bonsoir.
Deux procédures récursives à tester :

Private Function NbFich(ByVal Nom As String, Dos As Scripting.Folder) As Long
   Dim F As Scripting.File, SDos As Scripting.Folder
   For Each F In Dos.Files
      If F.Name Like "*" & Nom & "*" Then NbFich = NbFich + 1
      Next F
   For Each SDos In Dos.SubFolders
      NbFich = NbFich + NbFich(Nom, SDos)
      Next SDos
   End Function
Private Sub Fichiers(ByVal Nom As String, TLBx(), L As Long, Dos As Scripting.Folder)
   Dim F As Scripting.File, SDos As Scripting.Folder
   For Each F In Dos.Files
      If F.Name Like "*" & Nom & "*" Then
         L = L + 1
         TLBx(L, 1) = F.Name
         TLBx(L, 2) = F.Path
         End If
      Next F
   For Each SDos In Dos.SubFolders
      Fichiers Nom, TLBx, L, SDos
      Next SDos
   End Sub

 

[Dranreb]

À tester aussi leur invocation primaire comme ça :

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
   Dim FSO As Scripting.FileSystemObject
   Dim Rep As Scripting.Folder
   Dim TLBx(), L As Long
   If TextBox1 <> "" Then
      Set FSO = New Scripting.FileSystemObject
      Set Rep = FSO.GetFolder("C:\Users\a.chataignereau\Documents\Collègues\Commerciaux\Abdul")
      L = NbFich(TextBox1.Text, Rep)
      If L > 0 Then
         ReDim TLBx(1 To L, 1 To 2)
         L = 0
         Fichiers TextBox1.Text, TLBx, L, Rep
         ListBox1.List = TLBx
      Else
         MsgBox "Aucun fichier trouvé.", vbInformation, "Pas de fichier."
         TextBox1 = ""
         Cancel = True
         End If
      End If
   End Sub

 

[chaval]

Bonjour,
Merci énormément pour votre aide.
Malheureusement j'ai un message d'erreur. Sauriez-vous d'où peut venir le pb?

 

[chaval]

Est ce que vos propositions marchent avec le fichier que j'ai mis en exemple? Peut-être que je m'y prends mal pour insérer les codes au bon endroit? 🧐

 

[Dranreb]

Bonjour.
L'erreur vient de ce que vous n'avez pas déclaré L As Long dans la procédure appelante.

 

[chaval]

Merci pour votre réponse, mais je suis un peu perdue et je ne sais pas où le mettre.
Je suis novice et je fais beaucoup dans la débrouille/bidouille on va dire 😅

 

[Dranreb]

Mettez la à la place de la déclaration de Fich qui ne sert plus à rien puisque seules les procédures récursives les manipuleront

Dim TLBx() As Variant, L As Long

 

[chaval]

Merci pour votre temps
Quand je recherche un pdf maintenant il ne trouve plus aucun fichier pdf

 

[chaval]

Voici ma dernière version

 

[Dranreb]

La ListBox reste vide ?
Modifiez aussi la Sub UserForm_Initialise

 

[chaval]

C'est à dire? Je modifie quoi exactement?

 

[Dranreb]

Une fonction ListBoxOK permettrait de ne pas réécrire pratiquement deux fois la même chose :

Private Sub UserForm_Initialize()
   ListBox1.ColumnCount = 2 'nombre de colonne de la listbox
   ListBox1.ColumnWidths = "200;0" 'largeur des colonnes, la 2ème = 0
   ListBoxOK "*.pdf", "C:\Users\a.chataignereau\Documents\Collègues\Commerciaux\Abdul"
   End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
   Cancel = Not ListBoxOK(TextBox1.Text, "C:\Users\a.chataignereau\Documents\Collègues\Commerciaux\Abdul")
   If Cancel Then TextBox1.Text = ""
   End Sub
Private Function ListBoxOK(ByVal Masque As String, ByVal Chemin As String) As Boolean
   If InStr(Masque, "*") = 0 Then Masque = "*" & Masque & "*.pdf"
   Dim FSO As Scripting.FileSystemObject, Rep As Scripting.Folder
   Dim TLBx(), L As Long
   If Masque <> "" Then
      Set FSO = New Scripting.FileSystemObject
      Set Rep = FSO.GetFolder(Chemin)
      L = NbFich(Masque, Rep)
      ListBoxOK = L > 0
      If ListBoxOK Then
         ReDim TLBx(1 To L, 1 To 2)
         L = 0
         Fichiers Masque, TLBx, L, Rep
         ListBox1.List = TLBx
      Else
         MsgBox "Aucun fichier """ & Masque & """ trouvé.", vbInformation, "Pas de fichier."
         End If
      End If
   End Function
Private Function NbFich(ByVal Masque As String, ByVal Dos As Scripting.Folder) As Long
   Dim F As Scripting.File, SDos As Scripting.Folder
   On Error Resume Next
   For Each F In Dos.Files
      If F.Name Like Masque Then NbFich = NbFich + 1
      Next F
   For Each SDos In Dos.SubFolders
      NbFich = NbFich + NbFich(Nom, SDos)
      Next SDos
   End Function
Private Sub Fichiers(ByVal Masque As String, TLBx(), L As Long, ByVal Dos As Scripting.Folder)
   Dim F As Scripting.File, SDos As Scripting.Folder
   On Error Resume Next
   For Each F In Dos.Files
      If F.Name Like Masque Then
         L = L + 1
         TLBx(L, 1) = F.Name
         TLBx(L, 2) = F.Path
         End If
      Next F
   For Each SDos In Dos.SubFolders
      Fichiers Nom, TLBx, L, SDos
      Next SDos
   End Sub

 

[chaval]

Merci, j'ai mis le code donné ci-dessus, mais malheureusement il ne trouve toujours aucun fichier pdf, que ca soit dans le dossier ou sous dossier

 

[Dranreb]

Votre dernier classeur joint contient encore les anciennes procédures.
Et il y manque les procédures récursives de toute façon.