Copy A shape into all table cells

[SamG]

Hello all,

:)

I would like to paste a shape into all the table cells.

I have put a shape in the first cell in the table.

How can I copy this shape into all the cells?





Sub CopyPasteShape()


Dim oTable As Table, oCell As Cell
For Each oTable In ActiveDocument.Tables
For Each oCell In oTable.Range.Cells


'ActiveDocument.Shapes.Range(Array("Rectangle 6")).Select
' Selection.PasteAndFormat (wdPasteDefault)
'ActiveDocument.Shapes.Range(Array("Rectangle 7")).Select
'Selection.PasteAndFormat (wdPasteDefault)



Next oCell
Next oTable
End Sub



thanks for any advice

sam

[gmayor]

Use instead the macro listed at the end of http://www.gmayor.com/graphics_on_labels.htm

[SamG]

thank you Graham,

I will read through the article and apply the code.

:)

[SamG]

Hi Graham,

the code works great, but it for some reason did not copy the shape to the middle column at all.

in a 3 column table - it duplicated to all the cells - completely missing the middle column




Sub DuplicateLabels()
Dim oTable As Table
Dim oField As Field
With ActiveDocument
'Change the document type to mailing label
.MailMerge.MainDocumentType = wdMailingLabels
'Propagate the labels
WordBasic.MailMergePropagateLabel
'Check each table in the document
For Each oTable In .Tables
'Check each field in each table
For Each oField In .Fields
'If the field is a {NEXT} field,
If oField.Type = wdFieldNext Then
oField.Delete
'Delete it!
End If
Next oField
Next oTable
'Revert the document type to a normal document
.MailMerge.MainDocumentType = wdNotAMergeDocument
End With
End Sub


any ideas

thanks

sam

[gmayor]

Hmmmm. It works fine in Word 2010, but not in 2013 or 2016. This could reflect a change to how these versions process mail merge mailing labels, but I have not had time to investigate thoroughly. In the meantime the following workaround may help.


Sub DuplicateLabels()
Dim oTable As Table
Dim oField As field
With ActiveDocument
.MailMerge.MainDocumentType = _
wdMailingLabels
WordBasic.MailMergePropagateLabel
For Each oTable In .Tables
For Each oField In .Fields
If oField.Type = wdFieldNext Then
oField.Delete
End If
Next oField
Next oTable
.MailMerge.MainDocumentType = _
wdNotAMergeDocument
For Each oTable In .Tables
If oTable.Columns.Count = 3 And _
oTable.Columns(1).Width = oTable.Columns(2).Width Then
oTable.Columns(1).Select
Selection.Copy
oTable.Columns(2).Select
Selection.Paste
oTable.Columns(3).Delete
End If
Next oTable
End With
lbl_Exit:
Exit Sub
End Sub

[SamG]

Worked Perfectly

Thank you !
:)