Link to home
Start Free TrialLog in
Avatar of biker9
biker9Flag for Canada

asked on

Excel VBA extract text in shapes

Hello Experts,

the code in the attached file code text in a shapes, in a sequential order, it seems based upon the successive value of the shape. Is it possible to modify the code so that it reads the text based upon the shapes position in given range, preferably a column then row, ….

 ie: Column E, rows 11 through 85, then column F  rows 11 through 85,  column G rows 11 through 85 etc.
The result would read;
Text from 1
Text from 2
Text from 3
Text from 4
Text from 5 etc…

Thank you,
biker9
Paste-Excel-Shape-Text-to-Word-D.docx
Extract-text-from-shapes-2.xlsm
Avatar of Rgonzo1971
Rgonzo1971

Hi,

pls try this to reorder your shapes

Sub Macro()
Dim shp As Shape
Dim shps
Dim cl, rw, pos, strShp, aShapes, tmpSht, Idx, aNewShapes
    For Each shp In ActiveSheet.Shapes
        pos = shp.ZOrderPosition
        cl = shp.TopLeftCell.Column   ' if you want cell position
        rw = shp.TopLeftCell.Row
        'cl = shp.Left                ' if you want absolute position
        'rw = shp.Top
        strShp = strShp & pos & "," & cl & "," & rw & ";"
    Next
    strShp = Left(strShp, Len(strShp) - 1)
    aShapes = Split2d(strShp, ";", ",")
    Set tmpSht = Sheets.Add(After:=Sheets(Sheets.Count))
    tmpSht.Range("A1:C" & UBound(aShapes) + 1) = (aShapes)
    Sort.SortFields.Clear
    tmpSht.Sort.SortFields.Add Key:=Range("B1:B" & UBound(aShapes) + 1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    tmpSht.Sort.SortFields.Add Key:=Range("C1:C" & UBound(aShapes) + 1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With tmpSht.Sort
        .SetRange Range("A1:C" & UBound(aShapes) + 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    aNewShapes = tmpSht.Range("A1:C" & UBound(aShapes) + 1)
    Application.DisplayAlerts = False
    tmpSht.Delete
    Application.DisplayAlerts = True
    For Idx = 1 To UBound(aNewShapes)
    Set shp = Shapes.Item(Idx)
        MsgBox Shapes(Idx).Name
     ' your code
    Next
End Sub

Public Function Split2d(ByVal strInput As String, _
                        Optional RowDelimiter As String, _
                        Optional FieldDelimiter, _
                        Optional CoerceLowerBound As Long _
                        ) As Variant

' Split up a string into a 2-dimensional array.

' Works like VBA.Strings.Split, for a 2-dimensional array.
' Check your lower bounds on return: never assume that any array in
' VBA is zero-based, even if you've set Option Base 0
' If in doubt, coerce the lower bounds to 0 or 1 by setting
' CoerceLowerBound
' Note that the default delimiters are those inserted into the
'  string returned by ADODB.Recordset.GetString

On Error Resume Next

' Coding note: we're not doing any string-handling in VBA.Strings -
' allocating, deallocating and (especially!) concatenating are SLOW.
' We're using the VBA Join & Split functions ONLY. The VBA Join,
' Split, & Replace functions are linked directly to fast (by VBA
' standards) functions in the native Windows code. Feel free to
' optimise further by declaring and using the Kernel string functions
' if you want to.

' ** THIS CODE IS IN THE PUBLIC DOMAIN **
'    Nigel Heffernan   Excellerando.Blogspot.com

Dim i   As Long
Dim j   As Long

Dim i_n As Long
Dim j_n As Long

Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long

Dim arrTemp1 As Variant
Dim arrTemp2 As Variant

arrTemp1 = Split(strInput, RowDelimiter)

i_lBound = LBound(arrTemp1)
i_uBound = UBound(arrTemp1)

If VBA.LenB(arrTemp1(i_uBound)) <= 0 Then
    ' clip out empty last row: a common artifact in data
     'loaded from files with a terminating row delimiter
    i_uBound = i_uBound - 1
End If

i = i_lBound
arrTemp2 = Split(arrTemp1(i), FieldDelimiter)

j_lBound = LBound(arrTemp2)
j_uBound = UBound(arrTemp2)

If VBA.LenB(arrTemp2(j_uBound)) <= 0 Then
 ' ! potential error: first row with an empty last field...
    j_uBound = j_uBound - 1
End If

i_n = CoerceLowerBound - i_lBound
j_n = CoerceLowerBound - j_lBound

ReDim arrData(i_lBound + i_n To i_uBound + i_n, j_lBound + j_n To j_uBound + j_n)

' As we've got the first row already... populate it
' here, and start the main loop from lbound+1

For j = j_lBound To j_uBound
    arrData(i_lBound + i_n, j + j_n) = arrTemp2(j)
Next j

For i = i_lBound + 1 To i_uBound Step 1

    arrTemp2 = Split(arrTemp1(i), FieldDelimiter)

    For j = j_lBound To j_uBound Step 1

        arrData(i + i_n, j + j_n) = arrTemp2(j)

    Next j

    Erase arrTemp2

Next i

Erase arrTemp1

Application.StatusBar = False

Split2d = arrData

End Function

Open in new window

Regards
ASKER CERTIFIED SOLUTION
Avatar of [ fanpages ]
[ fanpages ]

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of biker9

ASKER

fanpages, what can I say but Amazing and Seamless!
Thank you very much.
biker9
:)

No problem at all.  I enjoyed working on something new (to me).