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

If x = 7 Then Cells(1, 1) = Data 

Cells( numéro de la ligne du fichier , 4)=Data 

path = Range("A1").Value

 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

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

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