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

nicolo9 Messages postés 16 Statut Membre -  
Le Pingou Messages postés 12276 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.

12 réponses

  1.
    Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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
    1. nicolo9 Messages postés 16 Statut Membre
       
      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
  2. nicolo9
     
    Bonjour,

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

    Merci.
    0
  3. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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
    1. nicolo9 Messages postés 16 Statut Membre
       
      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
  4. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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

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

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


    Salutations.
    Le Pingou
    0
    1. nicolo9 Messages postés 16 Statut Membre
       
      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
  7. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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
    1. nicolo9 Messages postés 16 Statut Membre
       
      Salut, je vais te montrer en image
      0
  8. nicolo9 Messages postés 16 Statut Membre
     
    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
    1. nicolo9 Messages postés 16 Statut Membre
       
      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
  9. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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
  10. nicolo9 Messages postés 16 Statut Membre
     
    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
    1. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
       
      Bonjour,
      Oui, la référence concernant Word :
      [Microsoft Word 15.0 Object Library]
      Salutations.
      Le Pingou
      0
    2. nicolo9 Messages postés 16 Statut Membre
       
      Re,
      C'est bon, j'ai activé ce qu'il faut. Regarde le dernier message datant de 11:31 AM.
      0
  11. nicolo9 Messages postés 16 Statut Membre
     
    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
    1. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
       
      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
      1. nicolo9 Messages postés 16 Statut Membre > Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention  
         
        Désolé...
        0
    2. nicolo9 Messages postés 16 Statut Membre
       
      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
  12. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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
    1. nicolo9
       
      Bonjour,

      Je vous remercie vous m'avez déjà apporté beaucoup d'aide.
      Cdlt.
      0
  13. Le Pingou Messages postés 12276 Date d'inscription   Statut Contributeur Dernière intervention   1 478
     
    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

Discussions similaires

question pix mot caché
aorum10 -
pixlagalere -

7 réponses