Recherche liste mot dans plusieurs fichiers

Bonjour

je sollicite votre aide car je galère

- J'ai un fichier "liste.txt" qui se présente sous la forme suivante :

mot1

mot2

mot3

etc ...

- Un répertoire de recherche "rep" qui contient plusieurs fichiers (de différents types) ainsi que des sous répertoire:

fichier1

fichier2

fichier3

sous_rep

fichier100

fichier101

etc...

Je souhaiterais créer un script/batch qui exécuterait la tache suivante :

Pour chaque mot de "liste.txt", rechercher si le mot existe dans les fichiers sous "rep" incluant ses sous répertoires et me renverrais le résultat dans un fichier texte sous la forme suivante :

mot1 présent dans fichier1, fichier2, fichier6,...

mot2 présent dans fichier1, fichier3, fichier4...

etc....

merci d'avance pour votre aide

Cordialement

Cédric

bonjour Indemyx,

bonjour le forum,

une proposition

Sub aargh()
    Sheets.Add
    lmf = "d:\downloads\listemots.txt"
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextfile(lmf)
    r = ts.readall
    ts.Close
    lm = Split(r, vbNewLine)
    Cells(1, 1).Resize(UBound(lm)) = Application.Transpose(lm)
    lfr "d:\downloads\", "*.txt", lm
    Open "resultats.txt" For Output As 1
    i = 1
    While Cells(i, 1) <> ""
        Ligne = Cells(i, 1) & " présent dans "
        j = 2
        sep = ""
        While Cells(i, j) <> ""
            Ligne = Ligne & sep & Cells(i, j)
            If sep = "" Then sep = ", "
            j = j + 1
        Wend
        If j > 2 Then Print #1, Ligne
        i = i + 1
    Wend
    Close 1
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub

Sub lfr(rep, filtre, lm, Optional n = 0)
    Set fso = CreateObject("scripting.filesystemobject")
    Set rep = fso.getfolder(rep)
    For Each repf In rep.subFolders
        lfr repf, filtre, lm, n + 1
    Next repf
    For Each f In rep.Files
        fn = f.Name
        If f.Name Like filtre Then
            Set ts = fso.OpenTextfile(f.Path)
            r = ts.readall
            For i = LBound(lm) To UBound(lm)
                If lm(i) <> "" Then
                    lig = i + IIf(LBound(lm) = 0, 1, 0)
                    If InStr(r, lm(i)) <> 0 Then
                        dc = Cells(lig, Columns.Count).End(xlToLeft).Column + 1
                        Cells(lig, dc) = f.Path
                    End If
                End If
            Next i
            ts.Close
        End If
    Next f
End Sub

Salut H2So4 (pas très rassurant comme nom quand on a bossé dans une raffinerie )

Merci pour ta réponse.

je vais tester ça

l

Re-bonjour,

Bon j'ai un petit soucie à l'éxécution de la macro :

"Erreur d'éxécution '62' : l'entrée dépasse la fin de fichier"

Débogage --> r = ts.readall (dans la Sub lfr)

Une idée ?

bonsoir,

je suppose qu'il s'agit d'un très gros fichier > 2GB ?

Il s'agit d'un gros répertoire avec plusieurs sous répertoire, mais en soi les fichier dans ces derniers ne sont pas si gros (quelques Mo)

Bonjour,

je ne comprends pas vraiment d'où vient le problème (je soupçonne une corruption dans un des fichiers), mais essaie ceci

Sub aargh()
    Sheets.Add
    lmf = "d:\downloads\liste.txt"
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.OpenTextfile(lmf)
    r = ts.readall
    ts.Close
    lm = Split(r, vbNewLine)
    Cells(1, 1).Resize(UBound(lm)) = Application.Transpose(lm)
    lfr "d:\downloads\", "*.txt", lm
    Open "resultats.txt" For Output As 1
    i = 1
    While Cells(i, 1) <> ""
        Ligne = Cells(i, 1) & " présent dans "
        j = 2
        sep = ""
        While Cells(i, j) <> ""
            Ligne = Ligne & sep & Cells(i, j)
            If sep = "" Then sep = ", "
            j = j + 1
        Wend
        If j > 2 Then Print #1, Ligne
        i = i + 1
    Wend
    Close 1
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub

Sub lfr(rep, filtre, lm, Optional n = 0)
    Set fso = CreateObject("scripting.filesystemobject")
    Set rep = fso.getfolder(rep)
    For Each repf In rep.subFolders
        lfr repf, filtre, lm, n + 1
    Next repf
    For Each f In rep.Files
        fn = f.Name
        If f.Name Like filtre Then
            Set ts = fso.OpenTextfile(f.Path)
            Do While ts.AtEndOfStream <> True
            r = ts.readline
            For i = LBound(lm) To UBound(lm)
                If lm(i) <> "" Then
                    lig = i + IIf(LBound(lm) = 0, 1, 0)
                    If InStr(r, lm(i)) <> 0 Then
                        dc = Cells(lig, Columns.Count).End(xlToLeft).Column + 1
                        Cells(lig, dc) = f.Path
                    End If
                End If
            Next i
            Loop
            ts.Close
            Set ts = Nothing
        End If
    Next f
    Set rep = Nothing
    Set fso = Nothing
End Sub