Relever mots-clés de fichiers Word vers un tableau Excel

nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention   -  
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,

Après plusieurs recherches sur des forums, je n'ai toujours pas trouvé comment récupérer des mots d'un fichier Word (ou même Excel) pour les écrire dans une case bien précise dans Excel.

Je m'explique : Mon but est de répertorier tous les dossiers/fichiers enregistrés dans le réseau informatique de l'usine dans laquelle je travaille.

De ce fait, j'organise une page Excel comme l'image ci-jointe.


Grâce à ma macro « Exécution », j'arrive à récupérer tous mes fichiers et dossiers dans le tableau de B5:Bfin pour les noms et de C5:Cfin pour les types du fichier. (En A1 j'ai mon dossier parent en path [H:\.......]) 


Sub Exécution()
    Dim path As String
    Dim myaddress As String
    Dim myRange As Range
    myaddress = "B4"
    Set myRange = Range(myaddress)
'Initialisation du chemin
    path = Range("A1").Value
    Call Lister_le_contenu(path, myRange)
    Range("B4:D4").Select
    Selection.AutoFilter
End Sub



Avec la macro intermédiaire Lister_le_contenu : 


Sub Lister_le_contenu(p_Path As String, ByRef p_Range As Range)
    Dim fso As New FileSystemObject
    Dim f As Folder
    Dim sf As Folder
    Dim myfile As File
    Dim myRange As Range
    Set myRange = p_Range
'Réference à l'objet du dossier
    Set f = fso.GetFolder(p_Path)
'Relever les sous-dossiers
    For Each sf In f.SubFolders
    myRange.Offset(1, 1).Value = sf.Name
    myRange.Offset(1, 2).Value = sf.Type
    Set myRange = myRange.Offset(1, 0)
    Next
'Relever les fichiers
    For Each myfile In f.Files
    myRange.Offset(1, 1).Value = myfile.Name
    myRange.Offset(1, 2).Value = myfile.Type
    myfile.Name
    Set myRange = myRange.Offset(1, 0)
    Call Lister_le_contenu(sf.path, myRange)
    Next
    Set p_Range = myRange
End Sub



Cependant pour les mots-clés, je ne sais pas comment m'y prendre pour relever un certain texte.

Mes fichiers Word sont disposés comme ceci :
1ère ligne : « Titre du document »
2ème ligne : « Mots-clés : abc, def, ghi, ... »

Mes fichiers Excel sont disposés comme ceci :
A1 : « Titre du document »
A2 : « Mots-clés : abc, def, ghi, ... »

J'ai déjà réussi à récupérer les mots clés dans des fichiers texte avec la macro :
(dans mon cas, j'ai écris ma ligne « Mots-clés : abc, def, ghi, ... » sur la ligne 7). 


Sub Mots_clés_fichier_txt()
    Dim ifile As Integer
    ifile = FreeFile
    Dim x As Long
    Dim Data As String
    Open "H:\test.txt" For Input As #ifile
    x = 1
    Do While Not EOF(1)
    Line Input #ifile, Data 'Récupère ta ligne
    If x = 7 Then Cells(1, 1) = Data 'Inscrit Data dans la 1ere case de ton classeur
    x = x + 1
    Loop
    Close #ifile
End Sub



Par contre, cette macro me fait récupérer ma valeur de mots-clés dans la case A1 d'Excel, et que pour un seul fichier. Or, je veux que ça se mette dans ma colonne D:D (D6 pour le Fichier1.xlsx, par exemple).

J'avais pensé à ouvrir, en macro, le fichier Word, le copier/coller en txt, copier la ligne avec les mots-clés, et supprimer ce fichier txt. Mais je n'y arrive pas du tout.


Merci de votre aide.
Bien à vous,
nicolo9.
A voir également:

12 réponses

Réponse 1 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Juste au passage, pour Mots_clés_fichier_txt
Vous avez : 
If x = 7 Then Cells(1, 1) = Data
'Inscrit Data dans la 1ere case de ton classeur
Pour 
Cells( numéro de la ligne du fichier , 4)=Data
Le 4 pour la colonne [D]

0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Merci, c'est vrai que je n'y avais pas pensé. Je n'ai déjà plus qu'à trouver la fonction pour le faire sur tous les fichiers .txt qui apparaissent dans ma colonne B, mais aussi pour les fichiers Excel et Word dont les mots-clés se trouvent dans une position bien précises d'une page de garde.
0
Réponse 2 / 12
nicolo9
 
Bonjour,

Personne n'a d'idée concernant mon problème ?

Merci.
0
Réponse 3 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Vous cherchez quoi d’autres… !
De plus nous ne savons même pas si la solution proposée pour le mot clé est satisfaisante… !


Salutations.
Le Pingou
0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Bonjour,

Mais si, je vous ai répondu que votre code fonctionnait.
Mais il me faut trouver la même chose mais qui fonctionne pour les fichiers Excel et Word.

Cdt
0
Réponse 4 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Merci de votre réponse, cette fois c’est clair.
Concernant la suite, je suis obligé de construire un ensemble qui correspond au mieux à vos codes, ce n’est pas simple…. !
Patience.

0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Premier point : pouvez-vous préciser le contenu de : 
path = Range("A1").Value



Salutations.
Le Pingou
0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
path = le dossier à développer par exemple "C:\User\nicolo"

Dès que l'on tape ce path, tout le calcul se fait pour relever tous les dossiers et fichiers contenus dans l'arborescence de ce path. (donc le nom et les types des dossiers/fichiers). Il restent plus qu'à ajouter les mots-clés.

A savoir que dans les fichiers Word et Excel, les mots clés se trouvent sous des noms de signets appelés "Keywords"
0
Réponse 6 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,

A savoir que dans les fichiers Word et Excel, les mots clés se trouvent sous des noms de signets appelés "Keywords"

Désolé mais là je ne comprends pas du tout ou les cherchés (signets n’existe pas sous Excel ….ou … !)

0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Salut, je vais te montrer en image
0
Réponse 7 / 12
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Bonjour,

Ben en fait sous Word c'est nommé par un "signet" et sous Excel c'est nommé par un "nom" à la place du nom de la cellule (après tu retrouves le nom dans le gestionnaire de noms).

Document Word



Document Excel

0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Ces deux images sont les pages de garde de tous les fichiers Excel et Word. Ce que je souhaite donc, c'est que dans le fichier que je t'ai envoyé hier, on explique à la macro que pour un fichier Word (exemple du premier tableau : Fichier3.doc), elle aille relever les mots qui se trouvent sous le signet "Keywords", et que pour un fichier Excel (par exemple : Fichier1.xlsx), elle aille copier le contenu de la cellule appelé "Keywords".
0
Réponse 8 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Voici ma proposition basé sur mon application virtuel (votre fichier pas disponible…. !):
Dans votre code [Lister_le_contenu] partie ['Relever les fichiers] juste après [myRange.Offset(1, 1).Value = myfile.Type] insére le code suivant pour détecter Excel ou Word et ainsi récupérer les mots clefs : 
 ext = Mid(myfile.Name, InStrRev(myfile.Name, ".") + 1)
If ext Like "doc*" Then
'    MsgBox "Doc Word"
    motclef = recu_word(p_Path & "\" & myfile.Name, "keywords")
    myRange.Offset(1, 2).Value = motclef
ElseIf ext Like "xls*" Then
'    MsgBox "Classeur Excel"
    motclef = recu_excel(p_Path & "\" & myfile.Name, "ER14_FINAL", "keywords")
    myRange.Offset(1, 2).Value = motclef
End If

En plus vous devez insérer les procédures dans un module : 
Function recu_word(Fichier As String, nomclef As String) As String
Dim objWord As New Word.Application
objWord.Documents.Open Fichier
objWord.Documents(1).Bookmarks(nomclef).Select
ActiveDocument.Bookmarks(nomclef).Select
recu_word = Selection
objWord.Documents(1).Close
objWord.Quit
Set objWord = Nothing
End Function

Function recu_excel(Fichier As String, Feuille As String, nomclef As String) As String
Dim r As String, recu As String
Dim cla As Workbooks
Dim wb As Workbook
Dim sh As Worksheet
Set cla = CreateObject("Excel.Application").Workbooks
Set wb = cla.Open(Fichier, , 1)
Set sh = wb.Worksheets(Feuille)
recu = sh.Range(nomclef)
wb.Close False
recu_excel = recu
End Function

En principe cela fonctionne chez moi.

0
Réponse 9 / 12
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Salut,

J'ai un souci dès le début de son calcul :





Faut-il activer une autre référence, en plus de Windows Script Host Object Model ?

Merci.
0
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Oui, la référence concernant Word :
[Microsoft Word 15.0 Object Library]
Salutations.
Le Pingou
0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Re,
C'est bon, j'ai activé ce qu'il faut. Regarde le dernier message datant de 11:31 AM.
0
Réponse 10 / 12
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Le code fonctionne quand la partie en gras italique souligné n'est pas présente, mais dès que je rajoute cette partie de code, ca ne fonctionne plus : 


Re,

Pour le document que je t'avais envoyé et que tu n'as pas reçu, en fait il suffit d'ouvrir un classeur vierge, et tu copies la macro suivante (ci-dessous) et tu lance la macro "ExécutionPagePrincipale" en rentrant un path an A1 :


<code>Sub ExécutionPagePrincipale()

    'Give names
        Dim Path As String
        Dim MyAddress As String
        Dim MyRange As Range

    'Give formula
        MyAddress = "B4"
        Set MyRange = Range(MyAddress)

    'Initialize path.
        Path = Range("A1").Value

    'Call macros
        Call SupprimeFeuille
        Call Vider_les_colonnes
        Call Lister_le_contenu(Path, MyRange)

    'Launch execution on the other sheets
        Sheets(2).Select
        Call Exécution

    'Return on "A1"
        Columns("B:D").EntireColumn.AutoFit
        Range("a1").Select

End Sub

Sub Exécution()

    'Give names
        Dim Path As String
        Dim MyAddress As String
        Dim MyRange As Range
        MyAddress = "B4"

    'Give formula
        For i = 1 To Sheets.Count - 1
            If Sheets(i).Name = ActiveSheet.Name Then
                Set MyRange = Range(MyAddress)
                Path = Range("A1").Value
                Call Vider_les_colonnes
                Range("a1").Select

                Call Lister_le_contenu(Path, MyRange)

                Sheets(i + 1).Activate
                Call Exécution
                Exit Sub
            End If
        Next i

    'Return on first sheet
        Sheets(1).Select
        Range("a1").Select

End Sub

Sub SupprimeFeuille()

    'Give names
        Dim Compteur As Integer, Nom As String
        Application.DisplayAlerts = False

    'Clear sheets except sheet 1
        If (Worksheets.Count - 1) >= 2 Then
            For Compteur = (Worksheets.Count - 1) To 2 Step -1
                Sheets(Compteur).Delete
            Next Compteur
        End If
    Application.DisplayAlerts = True

End Sub

Sub Vider_les_colonnes()

    'Clear contents
        Columns("B:H").Select
        Selection.ClearContents

    'Give format
        Columns("D:E").Select
        Selection.NumberFormat = "m/d/yyyy"

    'Give names of columns
        Range("b4").Select
        ActiveCell.FormulaR1C1 = "Nom du sous-dossier/fichier"
        Range("b4").Font.Color = RGB(124, 155, 220)
        Range("b4").Font.Bold = True

        Range("c4").Select
        ActiveCell.FormulaR1C1 = "Type du sous-dossier/fichier"
        Range("c4").Font.Color = RGB(0, 176, 80)
        Range("c4").Font.Bold = True

        Range("d4").Select
        ActiveCell.FormulaR1C1 = "Mots-clés"
        Range("d4").Font.Color = RGB(200, 76, 180)
        Range("d4").Font.Bold = True

End Sub

Sub Lister_le_contenu(p_Path As String, ByRef p_Range As Range)

    'Give names
        Dim fso As New FileSystemObject
        Dim f As Folder
        Dim sf As Folder
        Dim MyFile As File
        Dim MyRange As Range
        Dim MySheetName As String

    'Give formula
        Set MyRange = p_Range
        Set f = fso.GetFolder(p_Path)

    'Integrate folders
        For Each sf In f.SubFolders
            MyRange.Offset(1, 0).Value = sf.Name
            MyRange.Offset(1, 1).Value = sf.Type
            MySheetName = AddSheet_Func(MyRange.Worksheet, sf.Path, sf.Name)
            Set MyRange = MyRange.Offset(1, 0)
        Next

    'Integrate files
        For Each MyFile In f.Files
            MyRange.Offset(1, 0).Value = MyFile.Name
            MyRange.Offset(1, 1).Value = MyFile.Type

'Code for keywords
ext = Mid(MyFile.Name, InStrRev(MyFile.Name, ".") + 1)
If ext Like "doc*" Then
    motclef = recu_word(p_Path & "\" & MyFile.Name, "keywords")
    MyRange.Offset(1, 2).Value = motclef
ElseIf ext Like "xls*" Then
    motclef = recu_excel(p_Path & "\" & MyFile.Name, "ER14_FINAL", "keywords")
    MyRange.Offset(1, 2).Value = motclef
End If

            Set MyRange = MyRange.Offset(1, 0)
        Next

    Set p_Range = MyRange

End Sub

Function AddSheet_Func(P_Sheet As Worksheet, P_PathName As String, p_Name As String) As String

    'Give names
        Dim MySheet As Worksheet
        Dim MyRange As Range

    'Give path and summary on each sheet
        Set MySheet = Sheets.Add(, P_Sheet, 1, xlWorksheet)
        MySheet.Range("A1").Value = P_PathName
        Range("A9").Select
        ActiveCell.FormulaR1C1 = "Sommaire"
        MySheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
            "Sommaire!A1", TextToDisplay:="Sommaire"
        AddSheet_Func = (MySheet.Name)

End Function

Sub CreateIndexSheet()

    'Give names
        Dim wSheet As Worksheet
        Dim i As Integer
        Dim NbOfSheets As Integer
        Sheets(1).Select Range("E5").Select
        i = 0
        NbOfSheets = Worksheets.Count

    'Give hyperlinks
        For Each wSheet In Worksheets
            i = i + 1
            If i <> 1 And i <> NbOfSheets Then
            Select Case True
                Case InStr(1, wSheet.Name, " ") > 0
                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & wSheet.Name & "'!A1", TextToDisplay:=wSheet.Name
            Case Else
                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=wSheet.Name & "!A1", TextToDisplay:=wSheet.Name
            End Select
                ActiveCell.Offset(1, 0).Select
            End If
        Next

End Sub

Function recu_word(Fichier As String, nomclef As String) As String

Dim objWord As New Word.Application
objWord.Documents.Open Fichier
objWord.Documents(1).Bookmarks(nomclef).Select
ActiveDocument.Bookmarks(nomclef).Select
recu_word = Selection
objWord.Documents(1).Close
objWord.Quit
Set objWord = Nothing

End Function

Function recu_excel(Fichier As String, Feuille As String, nomclef As String) As String

Dim r As String, recu As String
Dim cla As Workbooks
Dim wb As Workbook
Dim sh As Worksheet
Set cla = CreateObject("Excel.Application").Workbooks
Set wb = cla.Open(Fichier, , 1)
Set sh = wb.Worksheets(Feuille)
recu = sh.Range(nomclef)
wb.Close False
recu_excel = recu

End Function
0
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour, valable pour aujourd'hui...¨
Merci, mais ce n'est pas la peine de poster tout le code.
Je ne suis pas aussi nul...=:(
Salutations.
Le Pingou
0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention   > Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention  
 
Désolé...
0
nicolo9 Messages postés 16 Date d'inscription   Statut Membre Dernière intervention  
 
Après test, quand il s'agit de document Word, au lieu d'écrire le mot-clé réel, il écrit carrément "Mots-clés" dans la case souhaitée, quelque soit le document Word contenant le signet "keywords".
0
Réponse 11 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Si cela ne fonctionne pas chez vous c’est certainement à cause de la structure du document Word que vous n’avez pas spécifié.
Je ne vais pas courir longtemps pour avoir les bonnes données… !

0
nicolo9
 
Bonjour,

Je vous remercie vous m'avez déjà apporté beaucoup d'aide.
Cdlt.
0
Réponse 12 / 12
Le Pingou Messages postés 12249 Date d'inscription   Statut Contributeur Dernière intervention   1 458
 
Bonjour,
Merci, vous baissez bien vite les bras…
Il semble que vous ne comprenez pas que sans la structure des documents Word il sera impossible d’avoir une solution correcte.
Bon dimanche.

0