Text near text


I have a lot of single line texts with single line text below (within 1' lets say).  Is it possible to replace all text with a concatenation of the two?  The contents of the text below tell me that it is a  2nd line, let's say it begins with '2'.


  • Here is my attempt at this. 

    This is what the Text looked like before:

    And here is what it looks like after the Macro runs:

    There are several areas this could be improved, but wanted to keep it simple to get you started. Here is the code:

    Sub FindTextConcatenation()
        Dim s As Shape
        Dim srText As ShapeRange, srFound As ShapeRange, srDelete As New ShapeRange
        'Find all the Text on the Active Page
        Set srText = ActivePage.Shapes.FindShapes(Type:=cdrTextShape)
        'Sort the Text ShapeRange Top to Bottom on the Page
        srText.Sort "@shape1.Top > @shape2.Top"
        'Loop through all the Text Shapes
        For Each s In srText.Shapes
            'If the shape has been added to the Delete ShapeRange we want to just skip it
            If srDelete.IndexOf(s) = 0 Then
                'Using CQL we find the line of text that is withing 1" of the other
                Set srFound = srText.Shapes.FindShapes(Query:="@com.StaticID <> " & s.StaticID & " and @Bottom < {" & s.BottomY & "in} and @Bottom > {" & s.BottomY - 1 & "in} and @CenterX > {" & s.CenterX - 1 & " in} and @CenterX < {" & s.CenterX + 1 & " in}")
                'Concatenate the two lines of Text
                s.Text.Story.Text = s.Text.Story.Text & " " & srFound.FirstShape.Text.Story.Text
                'Add the found text to the delete ShapeRange
                srDelete.Add srFound.FirstShape
            End If
        Next s
    End Sub

    Happy Coding!