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

chaval

XLDnaute Nouveau
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 ! :)
 

Pièces jointes

  • Ouvre PDF.xls
    60 KB · Affichages: 4
Solution
Une fonction ListBoxOK permettrait de ne pas réécrire pratiquement deux fois la même chose :
VB:
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...

Dranreb

XLDnaute Barbatruc
Bonsoir.
Deux procédures récursives à tester :
VB:
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

XLDnaute Barbatruc
À tester aussi leur invocation primaire comme ça :
VB:
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

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

Capture.JPG
 

Dranreb

XLDnaute Barbatruc
Une fonction ListBoxOK permettrait de ne pas réécrire pratiquement deux fois la même chose :
VB:
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
 
Dernière édition:

Discussions similaires

Réponses
12
Affichages
447

Statistiques des forums

Discussions
312 803
Messages
2 092 253
Membres
105 317
dernier inscrit
Tsi Badza