How to copy text to a shape VBA WORD

[panda789]

Hi, i have a template with rounded rectangle shapes. My problem is this:
I need to export a list of names from a program, it saves a .doc file with for example, 20 names. I need to put the names in those shapes automatically, by creating a button for example, but i can't find a way to do that. I tried using the "Application.GetOpenFileName" function from excel VBA, but didn't work.
I uploaded the template file that needs to be filled with the names. I have a .doc file with the names too.
Any help would be appreciated.
Thanks, Tudor.
PS: This is what I tried in VBA word. It auto-fills the shapes with only one Name, the one I entered.

Private Sub CommandButton1_Click()

Dim shp As Shape
Dim str As String
Dim strFileName As String


For Each shp In ActiveDocument.Shapes
str = "WS-ASD-105-BB"
shp.TextFrame.TextRange.Text = str
shp.TextFrame.TextRange.Paragraphs.Alignment = wdAlignParagraphCenter
shp.TextFrame.TextRange.Font.Size = 24
shp.TextFrame.MarginTop = 35

Next


End Sub

[gmayor]

Quite frankly I find it difficult to see why you are complicating matters by using shapes in the cells of the table (maybe a template downloaded from Avery). Why not simply put the data in the table itself, to which end this is a simple mail merge task? The only reason I can see for the rounded corners is if you are printing to plain paper, when these appear to be labels?

[panda789]

You're correct, it's a template from Avery. So, you suggest to make a table instead of these shapes? My main problem is still unsolved: how to copy the data and insert it in the table from another document? I want to get it done just by using 1 button.
Thanks

[gmayor]

You don't need to make a table, as you already have one. Just delete the shapes from each cell. Mail merge is the obvious approach, because of the narrow spacer cells, and you can run that from a macro (change the path in the first line as appropriate) The macro adds a header row to your Names document, then its a simple merge - see attached.


Option Explicit

Sub TestMacro()
Const strPathNames As String = "C:\Path\Names.docx"
Const strPathLabels As String = "C:\Path\Labels Template.docx"
Dim oNames As Document
Dim oLabels As Document
Dim oPara As Paragraph
Set oNames = Documents.Open(strPathNames)
For Each oPara In oNames.Paragraphs
If Len(oPara.Range.Text) < 3 Then oPara.Range.Delete
Next oPara
If InStr(1, oNames.Paragraphs(1).Range, "Names") = 0 Then
oNames.Range.InsertBefore "Names" & vbCr
End If
oNames.Close SaveChanges:=wdSaveChanges
Set oLabels = Documents.Open(strPathLabels)
With oLabels.MailMerge
.MainDocumentType = wdMailingLabels
.OpenDataSource name:=strPathNames, _
ConfirmConversions:=False, ReadOnly:=False, _
LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", _
Revert:=False, Format:=wdOpenFormatAuto, _
Connection:="", SQLStatement:="", _
SQLStatement1:="", SubType:=wdMergeSubTypeOther
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
lbl_Exit:
Set oNames = Nothing
Set oPara = Nothing
Exit Sub
End Sub

[panda789]

Thanks for your answer. Works great.