Sub RelocateTextBoxes()
Application.ScreenUpdating = False
Dim Doc As Document, i As Long, s As Long, v As Long, x As Long, Rng As Range, ArrShp() As String
Set Doc = ActiveDocument: ReDim ArrShp(0)
With Doc
  v = .ActiveWindow.View.Type: .ActiveWindow.View.Type = wdOutlineView
  For s = 1 To .Shapes.Count
    If Left(.Shapes(s).Name, 2) = "TB" Then
      i = i + 1: ReDim Preserve ArrShp(i): ArrShp(i) = Format(Split(.Shapes(s).Name, "TB")(1), "000")
    End If
  Next
  WordBasic.SortArray ArrShp()
  For s = 1 To UBound(ArrShp)
    i = CLng(ArrShp(s))
    With .Shapes("TB" & i)
      Set Rng = Doc.GoTo(What:=wdGoToPage, Name:=i)
      If s > 1 Then
        If Rng.Start < Doc.Shapes("TB" & i - 1).Anchor.End Then Rng.Start = Doc.Shapes("TB" & i - 1).Anchor.End
      End If
      x = -(Rng.Start < .Anchor.Start) '1= wdRelocateDown, 0 = wdRelocateUp
      If Rng.Start < .Anchor.Start Then
        Rng.End = .Anchor.Start - 1: Rng.Relocate Direction:=x
      Else
        Rng.Start = .Anchor.End + 1: Rng.Relocate Direction:=x
      End If
    End With
  Next
  .ActiveWindow.View.Type = v
End With
Application.ScreenUpdating = True
End Sub