Copy A shape into all table cells

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?

Code:

---


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

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

thank you Graham,

I will read through the article and apply the code.

:)

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

Code:

---

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

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.

Code:

---

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

---

Worked Perfectly

Thank you !
:)