Option Explicit
Public Sub readAutoCorrectEntries()
Dim appWord As Object
Dim o As Object
Dim l As Long
l = 2
Set appWord = CreateObject("Word.Application")
With ThisWorkbook.Worksheets(1)
.Cells(1, 1).Value = "Ersetzen:"
.Cells(1, 2).Value = "Durch:"
On Error Resume Next
For Each o In appWord.AutoCorrect.entries
If TypeName(o) = "AutoCorrectEntry" Then
.Cells(l, 1).Value = o.Name
.Cells(l, 2).Value = o.Value
End If
l = l + 1
If Err.Number <> 0 Then Exit For
Next o
End With
Set appWord = Nothing
End Sub