Only lightly tested -

Sub test()
Dim pos1 As Long, pos2 As Long, i As Long
Dim objWord As Object

On Error Resume Next
Set objWord = GetObject(, "word.application")
If Not objWord Is Nothing Then
s = objWord.activedocument.Range.Text
End If
On Error GoTo 0
If Len(s) = 0 Then
' can't get active document with text
Exit Sub
End If
pos2 = 1
While pos2 0
pos1 = InStr(pos2, s, "{")
If pos1 Then
pos2 = InStr(pos1, s, "}")

End If
If pos2 = pos1 + 2 And pos1 0 Then
i = i + 1
Cells(i, 1) = Mid$(s, pos1 + 1, pos2 - pos1 - 1)
Else: pos2 = 0
End If
Wend

End Sub


Could also probably Automate Word and use Word's Find method,

With objWord.Selection.Find
.ClearFormatting
.Text = "\{*\}"
.Replacement.Text = ""
.Forward = True
.Wrap = 2 ' wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With

return found strings (trimmed without the brackets) to say an array or
collection or directly into cells in Excel

Regards,
Peter T