Extract text in Text boxes

Question

I am pretty new to VBA coding and I am trying to extract the text in text boxes and insert the textbox text before the range paragraph..

This is what I came-up with so far:

Private Sub Document_New()
   Dim shp As Shape
   Dim oRngAnchor As Range
   Dim sString As String
   For Each shp In ActiveDocument.Shapes
       If shp.Type = msoTextBox Then
            shp.Select
            Selection.ShapeRange.TextFrame.TextRange.Select
           sString = Left(shp.TextFrame.TextRange.Text, _
             shp.TextFrame.TextRange.Characters.Count - 1)
           If Len(sString) > 0 Then
               Set oRngAnchor = shp.Anchor.Paragraphs(1).Range
               oRngAnchor.InsertBefore _
                 "*" & sString & "*"
           End If
           shp.Delete
       End If
   Next shp
End Sub

But it skips some of text boxes here and there, Please check and let me know if there's a way to extract text from all text boxes..

Your assistance is highly appreciated..

Thank you.

Answer 1

Try the next code, please. When iterate between shapes and delete one of them during iteration, a shape reference is lost. The shapes must be deleted at the end. Besides that, no selection is necessary:

Sub takeTextFromTextBoxes()
   Dim shp As Shape, oRngAnchor As Range, sString As String
   Dim shpR As ShapeRange, arrShp As Variant, k As Long, i As Long 'new declarations
   
   ReDim arrShp(ActiveDocument.Shapes.Count)
   For Each shp In ActiveDocument.Shapes
       i = i + 1
       If shp.Type = msoTextBox Then
           sString = Left(shp.TextFrame.TextRange.Text, _
             shp.TextFrame.TextRange.Characters.Count - 1)
           If Len(sString) > 0 Then
               Set oRngAnchor = shp.Anchor.Paragraphs(1).Range
               oRngAnchor.InsertBefore "*" & sString & "*"
           End If
           arrShp(k) = i: k = k + 1
       End If
   Next shp
   ReDim Preserve arrShp(k - 1)
   Set shpR = ActiveDocument.Shapes.Range(arrShp)
   shpR.Delete
End Sub