VBA : lister adresse des fichiers TXT contenant une chaine de caractère

Bonjour,

J'ai un classeur de traitement de données et je bloque sur une fonction vba pour un userform.

Je voudrais rechercher, dans un dossier et ces sous dossiers, les fichiers textes comportant le mot contenu dans la TextBox1 pour faire la liste des chemins de fichiers dans la colonne S de l'onglet de calcul

Exemple de liste dans la colonne S :

J'avoue que je ne sais pas comment m'y prendre avec les fichiers externes mais est ce vraiment possible de le faire?

Merci d'avance pour vos conseils

Bonjour Eralem et

Une petite présentation ICI serait la bienvenue

Si vous ne l'avez pas encore fait, je vous invite à lire :
- La charte du forum
- Quelques fonctionnalités du forum à connaître
qui vous aideront dans vos demandes et réponses sur ce forum.

Regardez aussi les petites icônes mises à votre disposition dans la barre de menu qui :
- vous permettent de poster un code (</>)
- ou de clôturer un fil lorsque vous avez terminé (V)

Merci pour votre participation

Concernant votre demande, cherchez "FSO" ou "File System Object"

Merci pour l'accueil et le conseil, je vais chercher de ce coté.

Bonjour,

J'arrive à avoir un script qui me permet l'extraction dans le format désiré, un collègue m'a fourni une base de travail.

Par contre je n'ai pas encore trouvé comment ajouter la condition :

si le fichier contient le mot contenu dans le TextBox1 tu le prend en compte sinon tu passe au suivant.

En attendant ce code pourra peut être aider quelqu'un et si vous avez des conseils pour l'étape qu'il me reste, je suis preneur

Dim numcell As Single
Dim maxniveau As Byte
Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Public Const OFN_ALLOWMULTISELECT = &H200&
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000&
Public Const OFN_HIDEREADONLY = &H4&
Public Const OFN_PATHMUSTEXIST = &H800&

' recuperer un dossier

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Long

Sub extractnum()
Dim mafeuil As Worksheet
Dim FSO As New FileSystemObject
Dim racine As Folder
Dim chemin As String

numcell = 1
'chemin a definir
chemin = "C:\dossier1\dossier2\dossier3"
'''''''''''''''''''''''''''''''
 Dim mySheetName As String, mySheetNameTest As String
    mySheetName = "numcond"

    On Error Resume Next
    mySheetNameTest = Worksheets(mySheetName).Name
    If Err.Number = 0 Then
    Else
        Err.Clear
        Worksheets.Add.Name = mySheetName
    End If
'''''''''''''''''''''''''''''''

    Dim sFolderPath As String
    sFolderPath = chemin
    If Right(sFolderPath, 1) <> "\" Then
        sFolderPath = sFolderPath & "\"
    End If
    If Dir(sFolderPath, vbDirectory) <> vbNullString Then
Sheets(mySheetName).Visible = True
Application.DisplayAlerts = False
Sheets(mySheetName).Delete
Application.DisplayAlerts = True

Else
        Miseajour.Show
        Exit Sub
    End If
''''''''''''''''''''''''''''''''''''

If chemin = "" Then Exit Sub

Set racine = FSO.GetFolder(chemin)

Set mafeuil = ThisWorkbook.Sheets.Add
If mySheetName = "" Then mafeuil.Name = racine.Drive.DriveLetter Else mafeuil.Name = mySheetName

dirfoldernum racine, mafeuil, 1

    With mafeuil.Outline
        .AutomaticStyles = False
        .SummaryRow = xlAbove
        .SummaryColumn = xlRight
    End With
  '  MsgBox maxniveau
      Cells.Select

' mise en forme auto
    Range("A1").Activate
    Cells.EntireColumn.AutoFit
    Range("A1").Select

' remplir les vides
Range("D1", [D1].End(xlDown)).Offset(, -2).Select
Range(Selection, Selection.Offset(0, 2)).Select
Dim MaCellule As Object
For Each MaCellule In Selection
If IsEmpty(MaCellule) Then
MaCellule.Value = MaCellule.Offset(-1, 0).Value
End If
Next MaCellule

End Sub

Sub dirfoldernum(root As Folder, mafeuil As Worksheet, niveau As Byte)

Dim FSO As New FileSystemObject
Dim f As File
Dim Dossier As Folder
Dim debut, fin As Single
If maxniveau < niveau Then maxniveau = niveau

printfoldernum root, mafeuil, niveau
debut = numcell
'liste des dossier
'On Error Resume Next
For Each f In root.Files
printfilenum f, mafeuil, niveau + 1
Next
For Each Dossier In root.SubFolders

dirfoldernum Dossier, mafeuil, niveau + 1

Next

fin = numcell - 1
If niveau > 1 Then
Rows(debut & ":" & fin).Select
Selection.Rows.Group
End If

End Sub

Sub printfoldernum(Dossier As Folder, mafeuil As Worksheet, niveau As Byte)
'MsgBox dossier.Name
Dim colonne As Byte
'colonne = 1
colonne = niveau

mafeuil.Cells(numcell, colonne) = Dossier.Name

numcell = numcell ' + 1

End Sub
Sub printfilenum(fichier As File, mafeuil As Worksheet, niveau As Byte)
'MsgBox fichier.Name
Dim colonne As Byte
colonne = 4
mafeuil.Cells(numcell, colonne) = fichier.Name

numcell = numcell + 1
End Sub

Hello Eralem

Voici un code qui est plus simple; il suffit juste de référencer la bibliothèque Microsoft Scripting Runtime

Option Explicit

Dim iLigneEcriture As Integer
Dim Masque As String
Dim Rep As String
Dim fso As FileSystemObject

Public Sub Main()
    Cells.Clear
    Set fso = New FileSystemObject
    'Initialisation de la ligne de sortie
    iLigneEcriture = 1    
    Masque = "001"    'à définir
    Rep = "C:\temp"

    'lancement du programme
    Parcourir Rep 'à définir

    'libération de la mémoire
    Set fso = Nothing
End Sub

Private Sub Parcourir(Path As String)

Dim aFolder As Folder
Dim thisFolder As Folder
Dim aFile As File
Dim aTextStream As TextStream
Dim aLine As String
Dim oFound As Boolean

    Set thisFolder = fso.GetFolder(Path)

    'parcours des fichiers
    For Each aFile In thisFolder.Files    
        'si c'est un fichier test
        If UCase(Right(aFile.Name, 3)) = "TXT" Then
            Set aTextStream = aFile.OpenAsTextStream(ForReading)
            oFound = False

            'parcours du fichier à la recherche de la chaine de caractère à trouver
            While Not (aTextStream.AtEndOfStream Or oFound)
                aLine = aTextStream.ReadLine
                oFound = InStr(1, aLine, Masque, vbTextCompare)
            Wend

            'si la chaine a été trouvé on écrit le chemin du fichier par exemple dans la colonne E
            If oFound Then
                Cells(iLigneEcriture, 5) = aFile.Path
                iLigneEcriture = iLigneEcriture + 1
            End If
            aTextStream.Close
        End If
    Next aFile

    'parcours des sous répertoires en récursif
    For Each aFolder In thisFolder.SubFolders
        Parcourir aFolder.Path
    Next aFolder
End Sub

Je te mets un fichier joins qui liste les fichiers texte du répertoire C:\temp contenant la chaine de caractère "001".

Tu auras juste à adapter le code pour le brancher à ton userform, et placer tes données de sortie où tu veux (pour remplir une listbox par exemple).

C'est TOP, merci beaucoup.

Avec ça je vais pouvoir finaliser mon fichier.