i have this code that can move 1 text from a paragraph and move to grouped object. Does anyone can help to move 2 text from a paragraph to a grouped object.
Sub text_paras_to_shapes()Dim sr1_index As LongDim sr1 As ShapeRangeDim sr2 As New ShapeRangeDim sr3 As New ShapeRangeDim para_count As LongDim counter_1 As LongDim s2 As ShapeDim tr As TextRange Optimization = True ActiveDocument.BeginCommandGroup "text paras to shapes" EventsEnabled = False On Error GoTo ErrHandler Set sr1 = ActiveSelectionRange If sr1.Count = 0 Then MsgBox "Nothing is selected." GoTo ExitSub End If sr1_index = 1 Do If sr1(sr1_index).Type = cdrTextShape Then sr2.Add sr1(sr1_index) sr1.Remove (sr1_index) End If sr1_index = sr1_index + 1 Loop Until sr1_index > sr1.Count If sr2.Count = 0 Then MsgBox "No text shape was found in the selection." GoTo ExitSub Else If sr2.Count > 1 Then MsgBox "More than one text shape was found in the selection." GoTo ExitSub End If End If para_count = sr2(1).Text.Story.Paragraphs.Count If para_count > sr1.Count Then MsgBox "The number of paragraphs in the text shape (" & para_count & ") is more than the number of rectangles (" & sr1.Count & ") in the selection." GoTo ExitSub End If sr1.Sort "@shape1.top>@shape2.top" For counter_1 = 1 To para_count Set tr = sr2(1).Text.Story.Paragraphs(counter_1) Set s2 = ActiveDocument.ActiveLayer.CreateArtisticText(0, 0, tr.Text, , , tr.Font, tr.Size, tr.Bold, tr.Italic, tr.Underline) s2.Fill = tr.Fill s2.CenterX = sr1(counter_1).CenterX s2.CenterY = sr1(counter_1).CenterY sr3.RemoveAll sr3.Add s2 sr3.Add sr1(counter_1) sr3.Group Next counter_1 ActiveSelection.Shapes.All.RemoveFromSelectionExitSub: Optimization = False EventsEnabled = True Application.Refresh ActiveDocument.EndCommandGroup Exit SubErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSubEnd Sub