Sub Demo()
Application.ScreenUpdating = False
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
End With
With ActiveDocument.Range
  .Cut
  .PasteSpecial DataType:=wdPasteText
  With .Find
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Text = "^13[ ^t]*^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
End With
With ActiveDocument.Range
  If .Characters.First <> vbCr Then .InsertBefore vbCr
  .InsertBefore "NAME" & vbTab & "TYPE"
  .ConvertToTable vbTab, 2
End With
Application.ScreenUpdating = True
End Sub