AJOUTER LE NOM DE L’AUTEUR D’UN FICHIER

Bonjour,
Pas certain que cela soit possible de retrouver les metadonnées d’un fichier Excel ou Word avec Power query, par contre avec une macro Excel, on peut lister les propriétés d’un fichier et les mettre dans un fichier excel et ensuite établir une fusion entre ce fichier et celui contenant les données à importer, cela permettra d’ajouter l’auteur par exemple. Le classeur doit contenir deux feuilles de calcul nommées respectivement “Metadata” et “Files”, la feuille Files contiendra deux résultat de requêtes Power query (voir ci après)

Requêtes Power query
Excel

let
    Source = Folder.Files(FolderPath),
    FilteredRows = Table.SelectRows(Source, each Text.EndsWith([Extension], "xlsx") or Text.EndsWith([Extension], "xls")),
    RemovedColumns = Table.RemoveColumns(FilteredRows,{"Extension", "Date accessed", "Date modified", "Date created", "Attributes", "Content"}),
    ReorderedColumns = Table.ReorderColumns(RemovedColumns,{"Folder Path", "Name"})
in
    ReorderedColumns

Word

let
    Source = Folder.Files(FolderPath),
    FilteredRows = Table.SelectRows(Source, each Text.EndsWith([Extension], "docx") or Text.EndsWith([Extension], "doc")),
    RemovedColumns = Table.RemoveColumns(FilteredRows,{"Extension", "Date accessed", "Date modified", "Date created", "Attributes", "Content"}),
    ReorderedColumns = Table.ReorderColumns(RemovedColumns,{"Folder Path", "Name"})
in
    ReorderedColumns

FolderPath est un paramètre contenant le nom du dossier contenant les fichiers à traiter.
Macro pour des fichiers Excel

Sub ExtractMetaDataExcelDoc()
    Dim objExcel As Object
    Dim strProperty As Object
    Dim ts As ListObject, intCptLine As Integer, tsRow As Integer, tsCol As Integer
    Dim wb As Workbook, wsFiles As Worksheet, wsMetaData As Worksheet
    
    Application.ScreenUpdating = False
    'Application.ScreenUpdating = True
  
    Set wb = ActiveWorkbook
    Set wsFiles = wb.Sheets("Files")
    Set wsMetaData = wb.Sheets("Metadata")
    wsFiles.Activate
    intCptLine = 2
    Set ts = Sheets("Files").ListObjects("ExcelFiles")
    tsRow = ts.Range.Row + 1
    tsCol = ts.Range.Column
    Cells(ts.Range.Row + 1, ts.Range.Column).Select
    
    While wsFiles.Cells(tsRow, tsCol).Value <> ""
        Set objExcel = Workbooks.Open(wsFiles.Cells(tsRow, tsCol).Value & wsFiles.Cells(tsRow, tsCol).Offset(0, 1).Value, False)
        wsMetaData.Activate
        Cells(intCptLine, 1).Select
        'If Range("A1").End(xlDown).Row = 2 Then Range("A1").End(xlDown).Activate Else Range("A1").End(xlDown).Offset(1, 0).Activate
          For Each strProperty In objExcel.BuiltinDocumentProperties
            On Error Resume Next
                ActiveCell.Value = objExcel.Name
                If strProperty.Name = "Author" Or strProperty.Name = "Auteur" Then
                  ActiveCell.Offset(0, 1).Value = strProperty.Name
                  ActiveCell.Offset(0, 2).Value = strProperty.Value
                  ActiveCell.Offset(0, 3).Value = Now()
                  intCptLine = intCptLine + 1
                  Exit For
                End If
                ActiveCell.Offset(1, 0).Value.Select
        Next
        
        Workbooks(objExcel.Name).Close False
        wsFiles.Activate
        tsRow = tsRow + 1
        Cells(tsRow, tsCol).Select
    Wend
    
    Set strProperty = Nothing
    
    Sheets("Metadata").Select
    Range("A1").End(xlDown).Offset(1, 2).Value = "EOF"
    Range("C1").Select
    While Selection <> "EOF"
        Selection.Offset(1, 0).Select
        If Selection = "" Then
            Selection.EntireRow.Delete
            Selection.Offset(-1, 0).Select
        End If
    Wend
    Selection.EntireRow.Delete
    Range("A1").Select
    Application.ScreenUpdating = True

End Sub

Macro pour des fichiers Word

Sub ExtractMetaDataWordDoc()
    Dim objWord As Object
    Dim strProperty As Object
    Dim objDoc As Object
    
    Application.ScreenUpdating = False

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False
        
    Sheets("Files").Activate
    Range("a1").Offset(1, 0).Select
    
    While Selection.Value <> ""
        Set objDoc = objWord.Documents.Open(Selection & Selection.Offset(0, 1).Value)
        Sheets("Metadata").Activate
        If Range("A1").End(xlDown).Row = 2 Then Range("A1").End(xlDown).Activate Else Range("A1").End(xlDown).Offset(1, 0).Activate
        For Each strProperty In objDoc.BuiltinDocumentProperties
            On Error Resume Next
                Selection = objDoc.Name
                If strProperty.Name = "Author" Or strProperty.Name = "Auteur" Then
                  Selection.Offset(0, 1) = strProperty.Name
                  Selection.Offset(0, 2) = strProperty.Value
                  Selection.Offset(0, 3) = Now()
                End If
                Selection.Offset(1, 0).Select
        Next
        objDoc.Close
        Sheets("Files").Activate
        Selection.Offset(1, 0).Select
    Wend
    
    objWord.Quit
    Set objWord = Nothing
    Set objDoc = Nothing
    Set strProperty = Nothing
    
    Sheets("Metadata").Select
    Range("A1").End(xlDown).Offset(1, 2).Value = "EOF"
    Range("C1").Select
    While Selection <> "EOF"
        Selection.Offset(1, 0).Select
        If Selection = "" Then
            Selection.EntireRow.Delete
            Selection.Offset(-1, 0).Select
        End If
    Wend
    Selection.EntireRow.Delete
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

En espérant que cela vous aidera à résoudre votre problème.
Cordialement

Bonjour,

La ligne en question n’est là que pour écrire EOF dans la dernière ligne et permettre ainsi de supprimer toutes les lignes inutiles qui ont été générées par les lignes situées avant Sheets(“Metadata”).select.
Appuyer sur la touche F5, cela devrait déclancher la suite du code et régler le soucis pour les fois suivantes, j’ai fait l’essai sur ma version et cela fonctionne.
Cordialement