Excel VBA extract text from shapes

Hello Experts,

I am trying to extract text from shapes but hangs when it confronts a grouped shape. Ideally, I would like to ungroup the shape, extract the text, then regroup the shape. Your help is appreciated.

Thanks,

biker9

I also have a follow up question which I will post separately.
Extract-Text-from-Shapes.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.

Martin LissOlder than dirtCommented:
I'm not sure if this is the result you want but if not you can probably modify it.


Sub Extract_Text_From_Shapes_InRange(ByRef objRange As Range)

Dim c As Integer
Dim rng As Range
Dim shp As Shape
Dim shpInGroup As Shape
Dim lngIndex As Long
  
    Range("w10").Select

    Set rng = ActiveCell
    
    On Error Resume Next
    For Each shp In ActiveSheet.Shapes
        If Not (Intersect(shp.TopLeftCell, objRange) Is Nothing) Or Not Intersect(shp.BottomRightCell, objRange) Is Nothing Then
            If shp.Type = msoGroup Then ' shp.Ungroup
                For lngIndex = 1 To shp.GroupItems.Count
                    Set shpInGroup = shp.GroupItems(lngIndex)
                    rng.Value = shpInGroup.TextFrame.Characters.Text
                    Set rng = rng.Offset(0, 1)
                    c = c + 1
                    If c = 1 Then
                        Set rng = rng.Offset(1, -1)
                        c = 0
                    End If
                Next
            Else
                rng.Value = shp.TextFrame.Characters.Text
                Set rng = rng.Offset(0, 1)
                c = c + 1
                If c = 1 Then
                    Set rng = rng.Offset(1, -1)
                    c = 0
                End If
            End If
        End If
    Next shp
 
End Sub

Open in new window

The duplicated code involving rng could be put into another Sub and called twice.
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:
Works perfectly Martin,
Thank you!
biker9

ps; pls note follow up question
0
Martin LissOlder than dirtCommented:
You're welcome and I'm glad I was able to help.

Marty - MVP 2009 to 2013
0
Martin LissOlder than dirtCommented:
Sorry but I don't work with Word so I can't help with your new question.
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.