Sub Demo()
Application.ScreenUpdating = False
Dim Shp As Shape, Rng As Range, Hght As Single, Wdth As Single
Hght = InchesToPoints(0.5):  Wdth = InchesToPoints(2)
With ActiveDocument
  Set Rng = Selection.Range.Characters.First
  Set Shp = .Shapes.AddShape(Type:=msoShapeRectangularCallout, _
    Left:=Rng.Information(wdHorizontalPositionRelativeToPage), _
    Top:=Rng.Information(wdVerticalPositionRelativeToPage) - Hght, _
    Width:=Wdth, Height:=Hght, Anchor:=Rng)
  .Tables.Add Range:=Shp.TextFrame.TextRange, Numrows:=1, numcolumns:=2
  Shp.TextFrame.TextRange.Characters.Last.Font.Hidden = True
End With
Application.ScreenUpdating = True
End Sub