Difficulté bouclage VBA recherche de mots dans fichiers word

Version imprimable

05/05/2022, 14h49
Métry_Lop

1 pièce(s) jointe(s)

Difficulté bouclage VBA recherche de mots dans fichiers word

Bonjour,
Je suis actuellement en train de créer un fichier Excel visant à la recherche de mots dans des fichiers Word à partir de VBA.
J'ai créer une liste de case à cocher dans un userform lors du lancement de la recherche visant à être plus précis dans la recherche.
Mon programme fonctionne, mais seulement pour 1 fichier à la fois. J'aimerai pouvoir boucler le programme afin que la procédure se fasse pour plusieurs fichiers word et que les informations (pages, occurences,nom du fichier) se rangent dans le tableau l'un à la suite des autres (sans devoir à chaque fois spécifier la cellule exacte).
Je ne sais pas si cela est clair pour vous, c'est pour cela que je vous ai joint mon fichier Excel.
Merci d'avance pour votre aide
Pièce jointe 618582

1 pièce(s) jointe(s)

Bonjour,

Une façon de faire la recherche des mots sur une série de documents contenus dans un dossier. A comprendre et adapter.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Option Explicit
 
'--- référence nécessaire: Microsoft Word xx.x Object Library
 
Sub Recherche()
    Dim kR As Long                  '--- n° ligne du tableau
    Dim aFamille() As String        '--- les noms des familles (max 10)
    Dim aMot() As String            '--- les mots à chercher (max 10)
    Dim sDossier As String          '--- dossier contenant les documents à traiter
    Dim sDossierFamille As String
    Dim sFichier As String
    Dim i As Long, j As Long, n As Long
    Dim WordApp As Object, WordDoc As Object
    '---
    kR = 9
    aFamille = Split(Range("F9"), ";")
    aMot = Split(Range("G9"), ";")
    sDossier = ThisWorkbook.Path                    '--- à adapter
    Set WordApp = CreateObject("Word.Application")
    '---
    For i = 0 To UBound(aFamille)
        Range("F" & kR) = Trim(aFamille(i))
        If Range("F" & kR) <> "" Then
            sDossierFamille = sDossier & "\"        '--- & aFamille(i) & "\"       '--- à adapter
            sFichier = Dir(sDossierFamille & "*.docx")
            While sFichier <> ""
                Range("H" & kR) = sFichier
                Set WordDoc = WordApp.Documents.Open(Filename:=sDossierFamille & sFichier, ReadOnly:=True)
                For j = 0 To UBound(aMot)
                    n = 0
                    WordApp.Selection.HomeKey Unit:=wdStory     '--- retourne au début du document
                    With WordDoc.Content.Find
                        .Text = Trim(aMot(j))                   '--- supprime les espaces inutiles en début et fin
                        If .Text <> "" Then
                            .Forward = True
                            .MatchWholeWord = True  '--- à vérifier
                            While .Execute
                                If .Found Then
                                    n = n + 1
                                    Range("I" & kR) = Range("I" & kR) & .Text & ": page " & WordApp.Selection.Information(1) & vbLf
                                End If
                            Wend
                            'Range("I" & kR) = Range("I" & kR) & .Text & ":" & n & "; "
                        End If
                    End With
                Next j
                WordDoc.Close
                sFichier = Dir
                kR = kR + 1
            Wend
        End If
    Next i
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

Cordialement.

06/05/2022, 09h25
Métry_Lop

1 pièce(s) jointe(s)

Bonjour,
Merci pour votre aide, je ne sais pas pourquoi mais il n'arrive pas à me lancer le programme lorsque je mets le chemin dossier et le nom du fichier?

Pièce jointe 618615
06/05/2022, 10h17
Métry_Lop

Okay C'est bon tout fonctionne,
J'aimerai juste aussi insérer le lien du document dans "recherche avancée".
Et que quand je sélectionne une famille, il aille faire la recherche dans un dossier spécifique?
Avez-vous une idée de comment faire?
Merci d'avance
06/05/2022, 13h56
EricDgn

1 pièce(s) jointe(s)

Bonjour,

Citation:

Et que quand je sélectionne une famille, il aille faire la recherche dans un dossier spécifique?

Pour cela il faut connaitre les noms de ces dossiers. C'était déjà approché à la ligne 24 du code déjà présenté.

Ci-attaché, une version qui fait la recherche sans s'occuper de la casse (lettre en majuscule = lettre en minuscule) et qui remplace les voyelles par des ? (joker) cela pour ne pas distinguer les voyelles accentuées des voyelles non accentuées. Ainsi par exemple: REVETEMENT = Revêtement = revêtement = revètement.

Cordialement.
09/05/2022, 08h47
Métry_Lop

C'est bizarre car lorsque je mets le nom du dossier dans lequel j'aimerai qu'il fasse la recherche, il continue tout de même à effectuer la recherche dans le dossier où se situe le fichier Excel. J'aimerai qu'il fasse une recherche dans un dossier spécifique à une famille, et si je sélectionne une autre famille, qu'il aille dans un autre dossier.
Et du coup pour insérer un lien pdf à chaque ligne du tableau? Une idée de comment faire?
Cordialement,
09/05/2022, 10h52
EricDgn

Bonjour,

A quel endroit (quelle cellule) de votre fichier Excel se trouve les noms des dossiers contenant les fichiers de chaque famille ?

Cordialement.
09/05/2022, 10h57
Métry_Lop

Bonjour,
je ne les ai pas inscrit mais c'est égal pour l'exemple.
09/05/2022, 12h15
EricDgn
Si le nom du dossier est identique à celui du nom de la famille (Couverture, VMC, etc.) alors ceci devrait focntionner:
Code:

1 2 sDossierFamille = sDossier & "\" & aFamille(i) & "\" sFichier = Dir(sDossierFamille & "*.docx")
Cordialement.
09/05/2022, 14h24
Métry_Lop

J'ai essayé cette solution mais sans succès
Pourtant les noms des dossiers sont les mêmes que les familles et cela ne fonctionne pas.
J'ai compris l'ensemble du programme et je trouve cela bizarre qu'il ne veuille pas tourner correctement lorsque j'utilise les lignes de codes que vous m'avez fournis précédemment.
Et sinon dans ce même dossier j'ai des versions pdf que j'aimerai insérer sous forme de lien dans la colonne J de mon tableau pour chacun des fichiers word. Est-il possible de faire cela?
Cordialement,

Bonjour,

Une possibilité (voir lignes 53, 54):

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
'--- référence nécessaire: Microsoft Word xx.x Object Library
 
Sub Recherche()
    Dim kR As Long                  '--- n° ligne du tableau
    Dim aFamille() As String        '--- les noms des familles (max 10)
    Dim aMot() As String            '--- les mots à chercher (max 10)
    Dim sDossier As String          '--- dossier contenant les documents à traiter
    Dim sDossierFamille As String
    Dim sFichier As String
    Dim i As Long, j As Long, n As Long
    Dim WordApp As Object, WordDoc As Object
    '---
    kR = 9
    aFamille = Split(Range("F9"), ";")
    aMot = Split(Range("G9"), ";")
    sDossier = ThisWorkbook.Path                                        '--- à adapter
    Set WordApp = CreateObject("Word.Application")
    '---
    For i = 0 To UBound(aFamille)
        Range("F" & kR) = Trim(aFamille(i))                             '--- supprime espaces éventuels en début et fin
        If Range("F" & kR) <> "" Then
            sDossierFamille = sDossier & "\" & Range("F" & kR) & "\"    '--- à adapter
            'Debug.Print sDossierFamille                                 '--- pour vérification éventuelle
            sFichier = Dir(sDossierFamille & "*.docx")
            While sFichier <> ""
                Range("H" & kR) = sFichier
                Set WordDoc = WordApp.Documents.Open(Filename:=sDossierFamille & sFichier, ReadOnly:=True)
                For j = 0 To UBound(aMot)
                    'n = 0
                    WordApp.Selection.HomeKey Unit:=wdStory     '--- retourne au début du document
                    WordApp.Selection.Find.ClearFormatting
                    With WordDoc.Content.Find
                        .Text = Trim(aMot(j))                   '--- supprime les espaces inutiles en début et fin
                        .Text = SansAccents(Trim(aMot(j)))      '--- remplace les voyelles par des ? (joker)
                        If .Text <> "" Then
                            .Forward = True
                            .MatchWholeWord = True              '--- à vérifier
                            .MatchWildcards = True              '--- accepte les jokers
                            .MatchCase = False                  '--- ne tient pas compte de la casse
                            While .Execute
                                If .Found Then
                                    'n = n + 1
                                    Range("I" & kR) = Range("I" & kR) & .Text & ": page " & .Parent.Information(wdActiveEndPageNumber) & ", ligne " & .Parent.Information(wdFirstCharacterLineNumber) & vbLf
                                End If
                            Wend
                            'Range("I" & kR) = Range("I" & kR) & .Text & ":" & n & "; "
                        End If
                    End With
                Next j
                WordDoc.Close
                sFichier = Replace(sFichier, ".docx", ".pdf")   '--- fichier pdf de même nom que le fichier docx
                ActiveSheet.Hyperlinks.Add Anchor:=Range("J" & kR), Address:=sDossierFamille & sFichier, TextToDisplay:=sFichier
                sFichier = Dir
                kR = kR + 1
            Wend
        End If
    Next i
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

Cordialement.

10/05/2022, 09h25
Métry_Lop

La solution pour créer les liens pdf fonctionne très bien.
Comment pourrais-je faire pour qu'il n'affiche pas les pages en double dans le tableau?
Merci en tout cas pour votre aide cela m'a vraiment beaucoup aidé!
Cordialement,

Bonjour,

Une façon de faire, que vous devriez pouvoir adapter:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Option Explicit
 
'--- référence nécessaire: Microsoft Word xx.x Object Library
 
Sub Recherche()
    Dim kR As Long                  '--- n° ligne du tableau
    Dim aFamille() As String        '--- les noms des familles (max 10)
    Dim aMot() As String            '--- les mots à chercher (max 10)
    Dim sDossier As String          '--- dossier contenant les documents à traiter
    Dim sDossierFamille As String
    Dim sFichier As String
    Dim i As Long, j As Long, page As Long, sTxt As String
    Dim WordApp As Object, WordDoc As Object
    '---
    kR = 9
    aFamille = Split(Range("F9"), ";")
    aMot = Split(Range("G9"), ";")
    For i = 1 To UBound(aFamille)
        aFamille(i) = Trim(aFamille(i))     '--- supprime espaces éventuels en début et fin d'epression
    Next i
    For i = 1 To UBound(aMot)
        aMot(i) = Trim(aMot(i))             '--- supprime espaces éventuels en début et fin d'epression
    Next i
    sDossier = ThisWorkbook.Path                                        '--- à adapter
    Set WordApp = CreateObject("Word.Application")
    '---
    For i = 0 To UBound(aFamille)
        Range("F" & kR) = Trim(aFamille(i))
        If Range("F" & kR) <> "" Then
            sDossierFamille = sDossier & "\" & Range("F" & kR) & "\"    '--- à adapter
            'Debug.Print sDossierFamille                                 '--- pour vérification éventuelle
            sFichier = Dir(sDossierFamille & "plus*.docx")
            While sFichier <> ""
                Range("H" & kR) = sFichier
                Set WordDoc = WordApp.Documents.Open(Filename:=sDossierFamille & sFichier, ReadOnly:=True)
                sTxt = ""                                       '--- texte occurences trouvées
                For j = 0 To UBound(aMot)
                    page = 0
                    WordApp.Selection.HomeKey Unit:=wdStory     '--- retourne au début du document
                    WordApp.Selection.Find.ClearFormatting
                    With WordDoc.Content.Find
                        .Text = SansAccents(aMot(j))            '--- remplace les voyelles par des ? (joker)
                        If .Text <> "" Then
                            .Forward = True
                            .MatchWholeWord = True              '--- à vérifier
                            .MatchWildcards = True              '--- accepte les jokers
                            .MatchCase = False                  '--- ne tient pas compte de la casse
                            While .Execute
                                If .Found Then
                                    If page <> .Parent.Information(wdActiveEndPageNumber) Then
                                        page = .Parent.Information(wdActiveEndPageNumber)
                                        sTxt = sTxt & aMot(j) & ": page " & page & ", ligne " & .Parent.Information(wdFirstCharacterLineNumber) & vbLf
                                    Else
                                        sTxt = Left(sTxt, Len(sTxt) - 1) & ", " & .Parent.Information(wdFirstCharacterLineNumber) & vbLf
                                    End If
                                End If
                            Wend
                        End If
                    End With
                Next j
                If Len(sTxt) > 1 Then Range("I" & kR) = Left(sTxt, Len(sTxt) - 1)       '--- supprime le dernier vbLf
                WordDoc.Close
                sFichier = Replace(sFichier, ".docx", ".pdf")
                ActiveSheet.Hyperlinks.Add Anchor:=Range("J" & kR), Address:=sDossierFamille & sFichier, TextToDisplay:=sFichier
                sFichier = Dir
                kR = kR + 1
            Wend
        End If
    Next i
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

Cordialement.

10/05/2022, 16h31
Métry_Lop

Et comment pourrais-je faire pour indiquer qu'une seule fois le mot rechercher dans la colonne "page".
Exemple: "Mot": page 1,3,8,19
"2ème Mot" page: 2,5,6
.....
Cordialement,

Pour cela, changer cette partie:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
                            While .Execute
                                If .Found Then
                                    If page = 0 Then
                                        page = .Parent.Information(wdActiveEndPageNumber)
                                        sTxt = sTxt & aMot(j) & ": page " & page & vbLf
                                    ElseIf page <> .Parent.Information(wdActiveEndPageNumber) Then
                                        page = .Parent.Information(wdActiveEndPageNumber)
                                        sTxt = Left(sTxt, Len(sTxt) - 1) & page & vbLf
                                    Else
                                        '--- ne rien faire (déjà indiqué), continuer
                                    End If
                                End If
                            Wend

mais le plus important pour vous est de bien comprendre tout cela.

Cordialement.

11/05/2022, 09h08
Métry_Lop

1 pièce(s) jointe(s)

Bonjour,
Merci j'ai compris l'ensemble du programme, mais maintenant il m'indique à chaque fois les résultats de la cellule précédente dans le tableau dans la colonne "page".
J'aimerai qu'il ne répète pas le mot dans chaque cellule car au bout de quelque lignes, la cellule devient énorme.
Je vous ai mis une capture d'écran de la colonne

Pièce jointe 618887
Cordialement

Bonjour,

Je n'ai pas ce problème, aussi je remets tout (avec ligne 55 ajout d'une virgule).

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
Option Explicit
 
'--- référence nécessaire: Microsoft Word xx.x Object Library
 
Sub Recherche()
    Dim kR As Long                  '--- n° ligne du tableau
    Dim aFamille() As String        '--- les noms des familles (max 10)
    Dim aMot() As String            '--- les mots à chercher (max 10)
    Dim sDossier As String          '--- dossier contenant les documents à traiter
    Dim sDossierFamille As String
    Dim sFichier As String
    Dim i As Long, j As Long, page As Long, sTxt As String
    Dim WordApp As Object, WordDoc As Object
    '---
    kR = 9
    aFamille = Split(Range("F9"), ";")
    aMot = Split(Range("G9"), ";")
    For i = 1 To UBound(aFamille)
        aFamille(i) = Trim(aFamille(i))     '--- supprime espaces éventuels en début et fin d'epression
    Next i
    For i = 1 To UBound(aMot)
        aMot(i) = Trim(aMot(i))             '--- supprime espaces éventuels en début et fin d'epression
    Next i
    sDossier = ThisWorkbook.Path                                        '--- à adapter
    Set WordApp = CreateObject("Word.Application")
    '---
    For i = 0 To UBound(aFamille)
        Range("F" & kR) = Trim(aFamille(i))
        If Range("F" & kR) <> "" Then
            sDossierFamille = sDossier & "\" & Range("F" & kR) & "\"    '--- à adapter
            'Debug.Print sDossierFamille                                 '--- pour vérification éventuelle
            sFichier = Dir(sDossierFamille & "*.docx")
            While sFichier <> ""
                Range("H" & kR) = sFichier
                Set WordDoc = WordApp.Documents.Open(Filename:=sDossierFamille & sFichier, ReadOnly:=True)
                sTxt = ""                                       '--- texte occurences trouvées
                For j = 0 To UBound(aMot)
                    page = 0
                    WordApp.Selection.HomeKey Unit:=wdStory     '--- retourne au début du document
                    WordApp.Selection.Find.ClearFormatting
                    With WordDoc.Content.Find
                        .Text = SansAccents(aMot(j))            '--- remplace les voyelles par des ? (joker)
                        If .Text <> "" Then
                            .Forward = True
                            .MatchWholeWord = True              '--- à vérifier
                            .MatchWildcards = True              '--- accepte les jokers
                            .MatchCase = False                  '--- ne tient pas compte de la casse
                            While .Execute
                                If .Found Then
                                    If page = 0 Then
                                        page = .Parent.Information(wdActiveEndPageNumber)
                                        sTxt = sTxt & aMot(j) & ": page " & page & vbLf
                                    ElseIf page <> .Parent.Information(wdActiveEndPageNumber) Then
                                        page = .Parent.Information(wdActiveEndPageNumber)
                                        sTxt = Left(sTxt, Len(sTxt) - 1) & ", " & page & vbLf
                                    Else
                                        '--- ne rien faire (déjà indiqué), continuer
                                    End If
                                End If
                            Wend
                        End If
                    End With
                Next j
                If Len(sTxt) > 1 Then Range("I" & kR) = Left(sTxt, Len(sTxt) - 1)       '--- supprime le dernier vbLf
                WordDoc.Close
                sFichier = Replace(sFichier, ".docx", ".pdf")
                ActiveSheet.Hyperlinks.Add Anchor:=Range("J" & kR), Address:=sDossierFamille & sFichier, TextToDisplay:=sFichier
                sFichier = Dir
                kR = kR + 1
            Wend
        End If
    Next i
    WordApp.Quit
    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub
 
Function SansAccents(s As String) As String
    Dim sAccents As String, i As Long
    sAccents = "aàâeéêèëiîoôöuù"
    SansAccents = s
    If Len(s) <> 0 Then
        For i = 1 To Len(sAccents)
            SansAccents = Replace(SansAccents, Mid(sAccents, i, 1), "?")
        Next i
    End If
End Function

Cordialement.

12/05/2022, 13h58
Métry_Lop

C'est parfait ca re fonctionne
Merci beaucoup pour votre aide!