Sub Demo()
Application.ScreenUpdating = False
Dim Shp As Shape, Rng As Range
With ActiveDocument
  For Each Shp In .Shapes
    With Shp
      If Not .TextFrame Is Nothing Then
        If Len(Trim(.TextFrame.TextRange.Text)) > 1 Then
          Set Rng = .Anchor
          With Rng
            .InsertBefore "Textbox start << "
            .Collapse wdCollapseEnd
            .InsertAfter " >> Textbox end"
            .Collapse wdCollapseStart
          End With
          Rng.FormattedText = .TextFrame.TextRange.FormattedText
        End If
        .Delete
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub