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
biker9Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
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
0
[ fanpages ]IT Services ConsultantCommented:
Hi,

I have taken a different approach.  My code is longer than that posted above, but I borrowed upon my previously documented Function blnQuick_Sort_Strings() as referenced in these previous threads:

[ http://www.experts-exchange.com/Q_20864109.html ]           (27 January 2004)
[ http://www.experts-exchange.com/Q_21601371.html ]           (20 October 2005)
[ http://www.experts-exchange.com/Q_21711174.html ]           (26 January 2006)
[ http://www.experts-exchange.com/Q_21818245.html ]           (18 April 2006)


Also, I have added (extensive) error handling throughout the existing code (I provided to you yesterday) so that any run-time errors are reported appropriately (& not ignored as they were in the code we used as a basis of the previous Question's solution).

The following (revised) code is taken from the attached workbook's code module for the [Sheet2] worksheet:

Option Explicit
' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28251212.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               Q_28251212
' Question Title:   Excel VBA extract text in shapes
' Question Asker:   biker9                                    [ http://www.experts-exchange.com/M_4584334.html ]
' Question Dated:   2013-09-27 at 04:48:23
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited                           [ http://NigelLee.info ]
' --------------------------------------------------------------------------------------------------------------

Dim lngErr_Number                                       As Long
Dim strErr_Description                                  As String
Public Sub Extract_Text_Inflow_Tbl()

' Dim blnErr_Ignore                                     As Boolean
  Dim blnOK                                             As Boolean
  Dim lngLoop                                           As Long
  Dim strArray()                                        As String
  
  On Error GoTo Err_Extract_Text_Inflow_Tbl
  
  blnOK = False
  
  ReDim strArray(0&) As String
  
  If (blnExtract_Text_From_Shapes([E11:R85], strArray())) Then
     If UBound(strArray) > 0& Then
        If (blnQuick_Sort_Strings(strArray())) Then
           For lngLoop = LBound(strArray) To UBound(strArray)
           
               If Len(Trim$(strArray(lngLoop))) > 0& Then
                  strArray(lngLoop) = Split(strArray(lngLoop), vbTab)(1&)
               End If ' If Len(Trim$(strArray(lngLoop))) > 0& Then
               
           Next lngLoop
        
           blnOK = blnQ_28250966(strArray)
        End If ' If (blnQuick_Sort_Strings(strArray())) Then
     End If ' If UBound(strArray) > 0& Then
  End If ' If (blnExtract_Text_From_Shapes([E11:R85], strArray())) Then
  
Exit_Extract_Text_Inflow_Tbl:

  On Error Resume Next
  
  Erase strArray
  ReDim strArray(0&) As String
  
  MsgBox IIf(blnOK, _
             "Text written to document successfully!", _
             "FAILED!"), _
         vbInformation Or vbOKOnly, _
         ThisWorkbook.Name
  
  Exit Sub
  
Err_Extract_Text_Inflow_Tbl:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
  
  On Error Resume Next
  
' If (blnErr_Ignore) Then
'    On Error GoTo Err_Extract_Text_Inflow_Tbl
'    Resume Next
' End If ' If (blnErr_Ignore) Then
  
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name
         
  blnOK = False
  
  Resume Exit_Extract_Text_Inflow_Tbl
  
End Sub
Private Function blnExtract_Text_From_Shapes(ByRef objRange As Range, _
                                             ByRef strArray() As String) As Boolean

  Dim blnErr_Ignore                                     As Boolean
  Dim blnReturn                                         As Boolean
  Dim lngArray                                          As Long
  Dim lngIndex                                          As Long
  Dim objGroupItem                                      As Shape
  Dim objShape                                          As Shape
  
  On Error GoTo Err_blnExtract_Text_From_Shapes
    
  blnErr_Ignore = False
  blnReturn = False
  lngArray = -1&
  
  For Each objShape In ActiveSheet.Shapes
    
      If Not (Intersect(objShape.TopLeftCell, objRange) Is Nothing) Or _
         Not (Intersect(objShape.BottomRightCell, objRange) Is Nothing) Then
        
         If objShape.Type = msoGroup Then
            For lngIndex = 1& To objShape.GroupItems.Count
               
                Set objGroupItem = objShape.GroupItems(lngIndex)
                    
                lngErr_Number = 0&
                blnErr_Ignore = True
                    
                If Len(Trim$(objGroupItem.TextFrame.Characters.Text)) > 0 Then
                   If lngErr_Number = 0& Then
                      lngArray = lngArray + 1&
                      
                      ReDim Preserve strArray(lngArray) As String
                      
                      strArray(lngArray) = Format$(objGroupItem.TopLeftCell.Column, String$(Len(CStr(Cells.Columns.Count)), "0")) & _
                                           Format$(objGroupItem.TopLeftCell.Row, String$(Len(CStr(Cells.Rows.Count)), "0")) & _
                                           vbTab & _
                                           objGroupItem.TextFrame.Characters.Text
                                                                 
                   End If ' If Err.Number = 0& Then
                End If ' If Len(Trim$(objGroupItem.TextFrame.Characters.Text)) > 0 Then

                blnErr_Ignore = False
                
            Next lngIndex
         Else
           lngErr_Number = 0&
           blnErr_Ignore = True
               
            If Len(Trim$(objShape.TextFrame.Characters.Text)) > 0 Then
               If lngErr_Number = 0& Then
                  lngArray = lngArray + 1&
                  
                  ReDim Preserve strArray(lngArray) As String
                  
                  strArray(lngArray) = Format$(objShape.TopLeftCell.Column, String$(Len(CStr(Cells.Columns.Count)), "0")) & _
                                       Format$(objShape.TopLeftCell.Row, String$(Len(CStr(Cells.Rows.Count)), "0")) & _
                                       vbTab & _
                                       objShape.TextFrame.Characters.Text
               End If ' If Err.Number = 0& Then
            End If ' If Len(Trim$(objGroupItem.TextFrame.Characters.Text)) > 0 Then
            
            blnErr_Ignore = False
         End If ' If objShape.Type = msoGroup Then
      End If ' If Not (Intersect(objShape.TopLeftCell, objRange) Is Nothing) Or Not (Intersect(objShape.BottomRightCell, objRange) Is Nothing) Then
    
  Next objShape
 
  blnReturn = True
  
Exit_blnExtract_Text_From_Shapes:

  On Error Resume Next
  
  Set objGroupItem = Nothing
  Set objShape = Nothing
  
  blnExtract_Text_From_Shapes = blnReturn
  
  Exit Function
  
Err_blnExtract_Text_From_Shapes:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
  
  On Error Resume Next
  
  If (blnErr_Ignore) Then
     On Error GoTo Err_blnExtract_Text_From_Shapes
     Resume Next
  End If ' If (blnErr_Ignore) Then
  
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name
         
  blnReturn = False
  
  Resume Exit_blnExtract_Text_From_Shapes
 
End Function
Private Function blnQ_28250966(ByRef strArray() As String) As Boolean

' Dim blnErr_Ignore                                     As Boolean
  Dim blnReturn                                         As Boolean
  Dim objDocument                                       As Object
  Dim objWord_Application                               As Object
  
  On Error GoTo Err_blnQ_28250966

' blnErr_Ignore = False
  blnReturn = False
  
  Set objWord_Application = CreateObject("Word.Application")
  
  If Not (objWord_Application Is Nothing) Then
     objWord_Application.Visible = True
  
     Set objDocument = objWord_Application.Documents.Open("C:\Users\RR\Documents\Paste-Excel-Shape-Text-to-Word-D.docx")
 End If ' If Not (objWord_Application Is Nothing) Then
  
  If Not (objDocument Is Nothing) Then
     objDocument.Bookmarks("Paste_Here").Range.Text = Join(strArray, vbCrLf)
     objDocument.Save
     
     blnReturn = True
  End If ' If Not (objDocument Is Nothing) Then
  
Exit_blnQ_28250966:

  On Error Resume Next
  
  If Not (objDocument Is Nothing) Then
     objDocument.Close SaveChanges:=False
     
     Set objDocument = Nothing
  End If ' If Not (objDocument Is Nothing) Then
  
  If Not (objWord_Application Is Nothing) Then
     objWord_Application.Quit
     
     Set objWord_Application = Nothing
  End If ' If Not (objWord_Application Is Nothing) Then
  
  blnQ_28250966 = blnReturn
  
  Exit Function
  
Err_blnQ_28250966:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
  
  On Error Resume Next
  
' If (blnErr_Ignore) Then
'    On Error GoTo Err_Q_28250966
'    Resume Next
' End If ' If (blnErr_Ignore) Then
  
  MsgBox "Error #" & CStr(lngErr_Number) & _
         vbCrLf & vbLf & _
         strErr_Description, _
         vbExclamation Or vbOKOnly, _
         ThisWorkbook.Name
         
  blnReturn = False
  
  Resume Exit_blnQ_28250966
  
End Function
Private Function blnQuick_Sort_Strings(ByRef strArray() As String, _
                                       Optional ByRef lngLow_Value As Long = -1&, _
                                       Optional ByRef lngHigh_Value As Long = -1&, _
                                       Optional ByVal blnAlpha_Sort As Boolean = True, _
                                       Optional ByVal blnIgnore_Case As Boolean = True) As Boolean

' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28251212.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               Q_28251212
' Question Title:   Excel VBA extract text in shapes
' Question Asker:   biker9                                    [ http://www.experts-exchange.com/M_4584334.html ]
' Question Dated:   2013-09-27 at 04:48:23
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited                           [ http://NigelLee.info ]
'
' Function:         blnQuick_Sort_Strings()
' Based upon:       [ http://www.experts-exchange.com/Q_20864109.html ]           (fanpages - 27 January   2004)
'                   [ http://www.experts-exchange.com/Q_21601371.html ]           (fanpages - 20 October   2005)
'                   [ http://www.experts-exchange.com/Q_21711174.html ]           (fanpages - 26 January   2006)
'                   [ http://www.experts-exchange.com/Q_21818245.html ]           (fanpages - 18 April     2006)
' --------------------------------------------------------------------------------------------------------------

  Dim blnReturn                                         As Boolean
  Dim blnSwap                                           As Boolean
  Dim lngLow                                            As Long
  Dim lngHigh                                           As Long
  Dim lngPivot                                          As Long
  Dim lngPosLow                                         As Long
  Dim lngPosHigh                                        As Long
  Dim strPivot                                          As String

  On Error GoTo Err_blnQuick_Sort_Strings
   
  blnReturn = False
   
  lngLow = IIf(lngLow_Value > -1&, lngLow_Value, LBound(strArray))
  lngHigh = IIf(lngHigh_Value > -1&, lngHigh_Value, UBound(strArray))

  If lngLow >= lngHigh Then
     blnQuick_Sort_Strings = True
     Exit Function
  End If

' If only 2 elements in this subdivision; swap them if out of order...

  If (lngHigh - lngLow) = 1& Then
     Select Case (True)
     
         Case (blnAlpha_Sort) And (blnIgnore_Case)                                                  ' Alpha Sort: Non-Case Dependent
             blnSwap = (UCase$(strArray(lngLow)) > UCase$(strArray(lngHigh)))
             
         Case (blnAlpha_Sort)                                                                       ' Alpha Sort: Case Dependent
             blnSwap = (strArray(lngLow) > strArray(lngHigh))
             
         Case Else                                                                                  ' Numeric Sort
             blnSwap = (Val(strArray(lngLow)) > Val(strArray(lngHigh)))                             ' Note: Val(...) only recognizes a period ["."] as a valid decimal separator
     
     End Select

     If (blnSwap) Then
        Call strSwap(strArray(lngLow), strArray(lngHigh))
     End If

     blnQuick_Sort_Strings = True
     Exit Function
  End If

' Pick a pivot element at random & move it to the end...

  lngPivot = CLng(Int(Rnd(1) * (lngHigh - lngLow) + 1&) + lngLow)

  Call strSwap(strArray(lngHigh), strArray(lngPivot))
         
  strPivot = UCase$(strArray(lngHigh))

  Do

      lngPosLow = lngLow
      lngPosHigh = lngHigh

' Move in from both sides towards the pivot element...

      Select Case (True)
      
          Case (blnAlpha_Sort) And (blnIgnore_Case)                                                 ' Alpha Sort: Non-Case Dependent
              Do While (lngPosLow < lngPosHigh) And (UCase$(strArray(lngPosLow)) <= UCase$(strPivot))
                 lngPosLow = lngPosLow + 1&
              Loop

              Do While (lngPosHigh > lngPosLow) And (UCase$(strArray(lngPosHigh)) >= UCase$(strPivot))
                 lngPosHigh = lngPosHigh - 1&
              Loop
              
          Case (blnAlpha_Sort)                                                                      ' Alpha Sort: Case Dependent
              Do While (lngPosLow < lngPosHigh) And (strArray(lngPosLow) <= strPivot)
                 lngPosLow = lngPosLow + 1&
              Loop

              Do While (lngPosHigh > lngPosLow) And (strArray(lngPosHigh) >= strPivot)
                 lngPosHigh = lngPosHigh - 1&
              Loop
      
          Case Else                                                             ' Numeric Sort
              Do While (lngPosLow < lngPosHigh) And (Val(strArray(lngPosLow)) <= Val(strPivot))     ' Note: Val(...) only recognizes a period ["."] as a valid decimal separator
                 lngPosLow = lngPosLow + 1&
              Loop
    
              Do While (lngPosHigh > lngPosLow) And (Val(strArray(lngPosHigh)) >= Val(strPivot))    ' Note: Val(...) only recognizes a period ["."] as a valid decimal separator
                 lngPosHigh = lngPosHigh - 1&
              Loop
      
      End Select
      
' If we haven't reached the pivot element then two elements on either side are out of order & need swapping...

      If lngPosLow < lngPosHigh Then
         Call strSwap(strArray(lngPosLow), strArray(lngPosHigh))
      End If

   Loop While (lngPosLow < lngPosHigh)

' Move the pivot element back to its proper place in the array...

  Call strSwap(strArray(lngPosLow), strArray(lngHigh))
         
' Recursively call the Sort procedure (pass the smaller subdivision first to use less stack space)...

  blnReturn = True
  
  If (lngPosLow - lngLow) < (lngHigh - lngPosLow) Then
     blnReturn = blnQuick_Sort_Strings(strArray(), lngLow, lngPosLow - 1&, blnAlpha_Sort, blnIgnore_Case)
     
     If (blnReturn) Then
         blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort, blnIgnore_Case)
     End If
  Else
     blnReturn = blnQuick_Sort_Strings(strArray(), lngPosLow + 1&, lngHigh, blnAlpha_Sort, blnIgnore_Case)
     
     If (blnReturn) Then
        blnReturn = blnQuick_Sort_Strings(strArray(), lngLow, lngPosLow - 1&, blnAlpha_Sort, blnIgnore_Case)
     End If
  End If
  
Exit_blnQuick_Sort_Strings:

  On Error Resume Next
   
  blnQuick_Sort_Strings = blnReturn
   
  Exit Function
   
Err_blnQuick_Sort_Strings:

  blnReturn = False
  
  Resume Exit_blnQuick_Sort_Strings
  
End Function
Private Sub strSwap(ByRef strFirst As String, _
                    ByRef strSecond As String)

  Dim strTemp                                           As String

  On Error Resume Next

  strTemp = strSecond
  strSecond = strFirst
  strFirst = strTemp

End Sub

Open in new window



Thank you for reviewing this proposal alongside that already provided.

BFN,

fp.
Q-28251212.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
biker9Author Commented:
fanpages, what can I say but Amazing and Seamless!
Thank you very much.
biker9
0
[ fanpages ]IT Services ConsultantCommented:
:)

No problem at all.  I enjoyed working on something new (to me).
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.