wimgielis.com

Duplicate table rows in Word

• Nov. 24, 2024

Introduction

I have some tables in Word documents where I frequently need to add rows, as a copy of existing rows. I want to select 1 or more cells or rows, and with the push of a ribbon icon in Word, duplicate those rows as exact copies. That makes editing much faster, I find. As this was not very trivial, I present the code below for you to use it. ChatGPT had a hard time figuring this one out too, so I need to do it old school and code it up myself.

The code

Sub Duplicate_Selected_Rows_Above()

    Dim table As table
    Dim firstRowIndex As Integer
    Dim lastRowIndex As Integer
    Dim i As Integer
    Dim j As Integer
    Dim numRows As Integer
    Dim numCols As Integer
    Dim rowData As Variant
    Dim cell As cell
    Dim cellContent As String

    'Check if the selection is in a table
    If Not Selection.Information(12) Then '12 = wdWithInTable
        MsgBox "Please place the cursor in a table."
        Exit Sub
    End If
    
    Set table = Selection.Tables(1)
    
    'Get the first and last row index of the selected range
    Set cell = Selection.Cells(1)
    firstRowIndex = cell.RowIndex
    Set cell = Selection.Cells(Selection.Cells.Count)
    lastRowIndex = cell.RowIndex
    
    'Get the number of rows and columns in the selection
    numRows = lastRowIndex - firstRowIndex + 1
    numCols = table.Columns.Count
    
    'Create an array to store the data
    ReDim rowData(1 To numRows, 1 To numCols)
    
    'Store the contents of the selected rows in the array
    For i = 1 To numRows
        For j = 1 To numCols
            'Get the cell content and trim it to remove extra whitespace
            cellContent = Trim(table.cell(firstRowIndex + i - 1, j).Range.text)
            If Right(cellContent, 2) = Chr(13) & Chr(7) Then
                cellContent = Left(cellContent, Len(cellContent) - 2) 'Remove trailing CR and LF
            End If
            rowData(i, j) = cellContent 'Remove trailing CR and LF
        Next
    Next
    
    'Insert new rows and populate them with the stored data
    For i = numRows To 1 Step -1
        table.Rows.Add BeforeRow:=table.Rows(firstRowIndex)
        For j = 1 To numCols
            table.cell(firstRowIndex, j).Range.text = rowData(i, j)
        Next
    Next
    
    'Move the cursor to the first cell of the first new row
    table.cell(firstRowIndex, 1).Select

End Sub

Enjoy !

• « Previous Excel article
• Next Excel article »