Sub Demo()
Application.ScreenUpdating = False
Dim MyData As DataObject
With ActiveDocument.Range
  .Font.Hidden = True
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = True
    .Font.Hidden = True
    .Replacement.Font.Hidden = False
    .Forward = True
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Text = "\<xs:element name[!\>]@\>"
    .Replacement.Text = "^&"
    .Execute Replace:=wdReplaceAll
    .Format = False
    .Text = "m[ai][nx]Occurs[!\>]@\>"
    .Replacement.Text = ">"
    .Execute Replace:=wdReplaceAll
    .Text = "\<xs:element name=([!\>]@)type=([!\>]@)\>"
    .Replacement.Text = "\1^t\2^p"
    .Execute Replace:=wdReplaceAll
    .Text = "\<xs:element name=([!\>]@)\>"
    .Replacement.Text = "\1^t^p"
    .Execute Replace:=wdReplaceAll
    .Text = " ([^13^t])"
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceAll
    .Text = Chr(34)
    .Replacement.Text = ""
    .Execute Replace:=wdReplaceAll
  End With
  .Copy
  Set MyData = New DataObject
  MyData.GetFromClipboard
  .Text = vbNullString
  .Text = MyData.GetText
  With .Find
    .Text = "^13[ ^t]*^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
  If .Characters.First <> vbCr Then .InsertBefore vbCr
  .InsertBefore "NAME" & vbTab & "TYPE"
End With
ActiveDocument.Range.ConvertToTable vbTab, 2
Application.ScreenUpdating = True
End Sub