Excel VBA extract text from shapes and paste results into a Word doc

Hello Experts,

I would like to extract text from shapes as in the attached worksheet, and paste the results into a Word doc.

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.

[ fanpages ]IT Services ConsultantCommented:

I see that the "Extract-Text-from-Shapes.xlsm" attachment already has a routine, Extract_Text_From_Shapes_InRange(), that transposes the text from the shapes to column [W].

I also see, from your past questions, that this was recently provided by MartinLiss:

[ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28250753.html ]

Do you just want the contents of column [W] pasted cell-by-cell to multiple lines within the MS-Word file attachment, "Paste-Excel-Shape-Text-to-Word-D.docx"?

Thank you for your clarification?


biker9Author Commented:
Pasting the contents of column W cell by cell to multiple lines of a Word doc would be ok, preferably however, not pasting into column W, but pasting the Excel shape contents directly into multiple lines of a word doc would be better for me.

Thank you,
[ fanpages ]IT Services ConsultantCommented:
OK, thanks.

Please find two files attached.

a) "Paste-Excel-Shape-Text-to-Word-D.docx" MS-Word document

I have made a single change to your provided file; the addition of a bookmark "Paste_Here".

b) "Q_28250966.xlsm" MS-Excel workbook

The (amended) Visual Basic for Applications code from the [Sheet2] worksheet code module is as follows:

Option Explicit
Sub Extract_Text_Inflow_Tbl()

  Dim strArray()                                        As String
  ReDim strArray(0&) As String
  Call Extract_Text_From_Shapes_InRange([e11:r85], strArray())
  If UBound(strArray) > 0& Then
     Call Q_28250966(strArray)
  End If ' If UBound(strArray) > 0& Then
  Erase strArray
  ReDim strArray(0&) As String
End Sub
Sub Extract_Text_From_Shapes_InRange(ByRef objRange As Range, _
                                     ByRef strArray() As String)

' 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)
                    If Len(Trim$(shpInGroup.TextFrame.Characters.Text)) > 0 Then
                       ReDim Preserve strArray(UBound(strArray) + 1&) As String
                       strArray(UBound(strArray)) = shpInGroup.TextFrame.Characters.Text
                    End If ' If Len(Trim$(shpInGroup.TextFrame.Characters.Text)) > 0 Then

'                   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
               If Len(Trim$(shp.TextFrame.Characters.Text)) > 0 Then
                  ReDim Preserve strArray(UBound(strArray) + 1&) As String
                  strArray(UBound(strArray)) = shp.TextFrame.Characters.Text
               End If ' If Len(Trim$(shpInGroup.TextFrame.Characters.Text)) > 0 Then
'               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
Private Sub Q_28250966(ByRef strArray() As String)

  Dim objDocument                                       As Object
  Dim objWord_Application                               As Object
  Set objWord_Application = CreateObject("Word.Application")
  objWord_Application.Visible = True
  Set objDocument = objWord_Application.Documents.Open("C:\Q_28250966\Paste-Excel-Shape-Text-to-Word-D.docx")
  objDocument.Bookmarks("Paste_Here").Range.Text = Join(strArray, vbCrLf)

  Set objDocument = Nothing
  Set objWord_Application = Nothing
End Sub

Open in new window

(I have commented-out MartinLiss' original statements that are no longer required)

Please note this line:
 Set objDocument = objWord_Application.Documents.Open("C:\Q_28250966\Paste-Excel-Shape-Text-to-Word-D.docx")

You will need to change the location "C:\Q_28250966\Paste-Excel-Shape-Text-to-Word-D.docx" to where your copy of this file is stored (locally).

Please execute the Sub Extract_Text_Inflow_Tbl() routine (as before) to copy the text contents of the Shape to the MS-Word document.

Note that there is a <Carriage Return> character & a <Line Feed> character between each text value.

This is controlled by the following statement with the MS-Excel Visual Basic for Applications code:

objDocument.Bookmarks("Paste_Here").Range.Text = Join(strArray, vbCrLf)

Change vbCrLf to whatever "delimiter" you wish to use between each successive Shape text value pasted into the MS-Word document.



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 fp,
thanks very much!


I have a followup question which I will post in a subsequent query.
[ fanpages ]IT Services ConsultantCommented:
You are very welcome.

I have added a comment/attachment with revised code to address your updated requirements within your new question thread:

[ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28251212.html#a39527120 ]
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.