To process the current table
Sub Macro1()
Dim oCol As New Collection
Dim oTable As Table
Dim oRng As Range
Dim lngIndex As Long
Dim sList As String: sList = ""
Set oTable = Selection.Tables(1)
Set oRng = oTable.Range
oRng.Select
With oRng.Find
Do While .Execute(FindText:="<[A-Z]{1,8}>", MatchWildcards:=True)
If oRng.InRange(oTable.Range) Then
On Error Resume Next
oCol.Add oRng.Text, oRng.Text
On Error GoTo 0
oRng.Collapse wdCollapseEnd
End If
Loop
End With
Set oRng = oTable.Range
oRng.MoveEndUntil Chr(13)
oRng.Collapse wdCollapseEnd
For lngIndex = 1 To oCol.Count
sList = sList & oCol(lngIndex)
If lngIndex < oCol.Count Then
sList = sList & vbCr
End If
Next lngIndex
oRng.Text = sList
lbl_Exit:
Set oTable = Nothing
Set oRng = Nothing
Exit Sub
End Sub