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

Posted on 2013-09-26
Medium Priority
Last Modified: 2013-09-27
Hello Experts,

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

Question by:biker9
  • 3
  • 2
LVL 35

Expert Comment

by:[ fanpages ]
ID: 39526157

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?



Author Comment

ID: 39526183
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,
LVL 35

Accepted Solution

[ fanpages ] earned 2000 total points
ID: 39526274
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.



Author Closing Comment

ID: 39526689
Works perfectly fp,
thanks very much!


I have a followup question which I will post in a subsequent query.
LVL 35

Expert Comment

by:[ fanpages ]
ID: 39527132
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 ]

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
If you need to forecast numbers -- typically for finance -- the Windows and Mac versions of Excel 2016 have a basket of tools to get the job done.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…
How can you see what you are working on when you want to see it while you to save a copy? Add a "Save As" icon to the Quick Access Toolbar, or QAT. That way, when you save a copy of a query, form, report, or other object you are modifying, you…

600 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question