Attribute VB_Name = "S_WordMetaDaten"
Option Explicit

Sub WordMetaDaten()

Dim ColNr    As Integer
Dim MaxCols  As Integer
Dim NextCol  As Integer

Dim MaxRows  As Long
Dim NextLine As Long

Dim DObject  As Object
Dim DocInfo  As Object
Dim WObject  As Object

Dim GetCol   As Range

Dim FileName As String
Dim Fullname As String
Dim ProbName As String

MaxCols = ActiveSheet.UsedRange.Columns.Count
If MaxCols > 1 Then Range(Columns(2), Columns(MaxCols)).Delete Shift:=xlToLeft
NextLine = 1
Cells(NextLine, 1).Value = "Fullname"
Cells(NextLine, 2).Value = "Author"
Cells(NextLine, 3).Value = "Creation Date"
Cells(NextLine, 4).Value = "Last save time"
NextCol = 4
MaxRows = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
Set WObject = CreateObject("Word.Application")
WObject.Visible = False
For NextLine = 2 To MaxRows
    Fullname = Cells(NextLine, 1).Value
    FileName = Split(Fullname, "\")(UBound(Split(Fullname, "\")))
    If Left(FileName, 1) = "~" Then Stop
    If Left(FileName, 1) = "~" Then GoTo NextFile
    ''WObject.Visible = True
    Set DObject = WObject.Documents.Open(Fullname)
    For Each DocInfo In DObject.BuiltinDocumentProperties
        On Error Resume Next
        If DocInfo.Name = vbNullString Then GoTo NextProb
        If DocInfo.Value = vbNullString Then GoTo NextProb
        On Error GoTo 0
        ProbName = DocInfo.Name
        If Left(ProbName, 7) = "Number " Then GoTo NextProb
        Set GetCol = Rows(1).Find(What:=ProbName, LookIn:=xlValues, Lookat:=xlWhole)
        If Not GetCol Is Nothing Then
           ColNr = GetCol.Column
        Else
           'GoTo NextProb   ' keine unbekannten Informationen sammeln
           NextCol = NextCol + 1
           ColNr = NextCol
           Cells(1, NextCol).Value = ProbName
        End If
        Cells(NextLine, ColNr).Value = DocInfo.Value
NextProb:
    On Error GoTo 0
    Next DocInfo
    DObject.Close SaveChanges:=False
NextFile:
Next NextLine
WObject.Quit
Set WObject = Nothing
Set DObject = Nothing
Set DocInfo = Nothing
Cells.Select
Selection.Columns.AutoFit
Cells.Select
Selection.AutoFilter
Application.ScreenUpdating = True

End Sub