excel va chercher un mot cle dans word

[vserrano]

Bonjour à tous,

Me revoilà avec une question :
J'ai un fichier excel avec des titres de formation, ces titres avec le détail se trouve dans word et j'ai besoin de connaitre le numéro de la page auquel il correspond.

Est ce possible ?

 

[Nairolf]

Salut,

Le fil ci-dessous répondra peut-être à ta question:
https://www.excel-downloads.com/threads/recherche-de-texte-dans-word-a-partir-dexcel.105609/

 

[Lone-wolf]

Bonjour vserrano (serrano - me rappelle quelqu'un ici en Suisse), Nairolf

Excel ! Va chercher le mot "clé" dans Word, pour que je puisse ouvrir la cellule!!

 

[job75]

Bonjour vserrano, Nairolf, Lone-wolf,

Je suppose que les textes recherchés sont repérés dans Word par des signets.

Pour récupérer le numéro de page d'un signet voyez cette macro :

Sub PageSignetWord()
Dim chemin$, NomDoc$, NomSignet$, WDoc As Object, NumPage%
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
NomSignet = "MonSignet" 'à adaptet
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
NumPage = WDoc.Bookmarks(NomSignet).Range.Information(3) '3 => wdActiveEndPageNumber
MsgBox "Le signet '" & NomSignet & "' " & IIf(NumPage, "se trouve page " & NumPage, "est introuvable...")
WDoc.Close False
End Sub

Maintenant si vous voulez plus il vous faudra joindre le fichier Excel et le document Word.

A+

 

[Lone-wolf]

Bonjour job75

 

[job75]

Re,

Pour lister tous les signets du document Word :

Sub ListeSignetsWord()
Dim chemin$, NomDoc$, NomSignet$, WDoc As Object, lig&, bm As Object
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Application.ScreenUpdating = False
[A:B].ClearContents 'RAZ
[A1] = "Signet": [B1] = "Page": lig = 1
For Each bm In WDoc.Bookmarks
    lig = lig + 1
    Cells(lig, 1) = bm.Name
    Cells(lig, 2) = bm.Range.Information(3) '3 => wdActiveEndPageNumber
Next
WDoc.Close False
End Sub

A+

 

[job75]

Bonjour vserrano, Lone-wolf,

Une solution pour rechercher un mot clé dans Word (sans signet) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim mot$, chemin$, NomDoc$, WDoc As Object, d As Object, w As Object, p%, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
mot = CStr([D2])
If mot <> "" Then
    chemin = ThisWorkbook.Path & "\" 'à adapter
    NomDoc = "MonDoc.docx" 'à adapter
    On Error Resume Next
    Set WDoc = GetObject(chemin & NomDoc)
    If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
    Set d = CreateObject("Scripting.Dictionary")
    For Each w In WDoc.Words
        If Trim(w.Text) = mot Then
            p = w.Information(3) '3 => wdActiveEndPageNumber
            d(p) = d(p) + 1 'comptage
        End If
    Next
    WDoc.Close False
    '---restitution---
    n = d.Count
    If n Then
        If FilterMode Then ShowAllData 'si la feuille est filtrée
        [C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        [D5].Resize(n) = Application.Transpose(d.items)
    End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichier zippés joints à placer dans le même dossier.

A+

 

[job75]

Bonjour vserrano, Lone-wolf, tatiak, le forum, coucou chère ânesse,

Oui tatiak c'est certainement plus rapide avec la méthode Find. mais tu ne traites que la 1ère occurrence.

Et ton fichier Doc_azerty ne s'ouvre pas chez moi.

Pour continuer avec les Words si l'on veut rechercher un texte constitué de plusieurs mots comme "Lone-wolf" :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, L%, chemin$, NomDoc$, WDoc As Object, d As Object, w As Object, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2]): L = Len(texte)
If texte <> "" Then
    chemin = ThisWorkbook.Path & "\" 'à adapter
    NomDoc = "MonDoc.docx" 'à adapter
    On Error Resume Next
    Set WDoc = GetObject(chemin & NomDoc)
    If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
    Set d = CreateObject("Scripting.Dictionary")
    For Each w In WDoc.Words
        If Not texte Like Trim(w.Text) & "*" Then GoTo 1
        If WDoc.Range(w.Start, w.Start + L) <> texte Then GoTo 1
        n = w.Information(3) '3 => wdActiveEndPageNumber
        d(n) = d(n) + 1 'comptage
1   Next
    WDoc.Close False
    '---restitution---
    n = d.Count
    If n Then
        If FilterMode Then ShowAllData 'si la feuille est filtrée
        [C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        [D5].Resize(n) = Application.Transpose(d.items)
    End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichiers (2).

Bon dimanche.

 

[job75]

Re,

Recherche de toutes les occurrences avec la méthode Find :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, chemin$, NomDoc$, WDoc As Object, d As Object, deb&, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2])
If texte <> "" Then
    chemin = ThisWorkbook.Path & "\" 'à adapter
    NomDoc = "MonDoc.docx" 'à adapter
    On Error Resume Next
    Set WDoc = GetObject(chemin & NomDoc)
    On Error GoTo 0
    If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
    Set d = CreateObject("Scripting.Dictionary")
    Do
        With WDoc.Range(deb).Find
            .Text = texte
            .Forward = True
            .Execute
            If Not .Found Then Exit Do
            n = .Parent.Information(3) '3 => wdActiveEndPageNumber
            d(n) = d(n) + 1 'comptage
            deb = .Parent.End
        End With
    Loop
    WDoc.Close False
    '---restitution---
    n = d.Count
    If n Then
        If FilterMode Then ShowAllData 'si la feuille est filtrée
        [C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        [D5].Resize(n) = Application.Transpose(d.items)
    End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichiers (3).

Comparaison des durées d'exécution pour les 10 occurrences de "Bonjour" (uniquement la recherche) :

- fichiers (2) => 0,20 seconde

- fichiers (3) => 0,15 seconde.

A+

 

[job75]

Bonjour vserrano, Lone-wolf, tatiak, le forum,

J'ai voulu voir ce que donne la recherche avec la fonction InStr :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, L%, chemin$, NomDoc$, WDoc As Object, d As Object, wdc$, deb&, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2]): L = Len(texte)
If texte <> "" Then
    chemin = ThisWorkbook.Path & "\" 'à adapter
    NomDoc = "MonDoc.docx" 'à adapter
    On Error Resume Next
    Set WDoc = GetObject(chemin & NomDoc)
    On Error GoTo 0
    If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
    Set d = CreateObject("Scripting.Dictionary")
    wdc = Replace(WDoc.Content, vbCr & Chr(7), vbCr) 'épuration nécessaire s'il y a des tableaux
    deb = 1 - L
    Do
        deb = InStr(deb + L, wdc, texte)
        If deb = 0 Then Exit Do
        n = WDoc.Range(deb - 1, deb + L - 1).Information(3) '3 => wdActiveEndPageNumber
        d(n) = d(n) + 1 'comptage
    Loop
    WDoc.Close False
    '---restitution---
    n = d.Count
    If n Then
        If FilterMode Then ShowAllData 'si la feuille est filtrée
        [C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
        [D5].Resize(n) = Application.Transpose(d.items)
    End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Eh bien InStr est 2 à 3 fois plus rapide que la méthode Find.

Sur ces fichiers (4) la recherche de "Bonjour" se fait en 0,05 seconde.

A+

 

[job75]

Re,

Un inconvénient majeur avec la macro des fichiers (3) - méthode Find.

Si le texte recherché se trouve dans plusieurs tableaux, la macro ne parvient pas à sortir du 1er tableau.

Elle boucle sans fin...

Sortir alors par le Gestionnaire des tâches puis exécuter le code :

Set WDoc = GetObject(ThisWorkbook.Path & "\MonDoc.docx")
WDoc.Close False

pour pouvoir ouvrir ou supprimer MonDoc.docx.

Il n'y a pas ce problème avec les fichiers (4) - InStr.

A+

 

[vserrano]

Bonjour à tous;

J'ai pris beaucoup de retard je regarde tout ce que vous m'avez proposé.
Merci encore pour votre aide

 

[job75]

Bonjour le forum,

En fait il n'y a pas de problème avec les tableaux, Find trouve toutes les occurrences si l'on utilise :

With WDoc.Range(deb, deb).Find

C'était simple mais j'ai eu du mal à trouver...

Ci-joint les fichiers finaux pour tester les 2 méthodes.

A+