wimgielis.com

Tabelrijen dupliceren in Word

• 24/11/2024

Inleiding

In een aantal Word documenten heb ik tabellen waar ik regelmatig rijen moet toevoegen, als een exacte kopie van bestaande rijen. Ik wil dan graag 1 of meerdere cellen of rijen selecteren, en met de druk op een ribbon icoon in Word, deze rijen dupliceren als exacte kopies. Dit maakt tabellen bewerken zeker sneller, vind ik. Aangezien dit niet triviaal makkelijk was, presenteer ik hier de code zodat jij die kan toepassen en gebruiken. ChatGPT had er ook een harde dobber aan om deze code uit te vogelen, dus deed ik het maar old school en schreef de code zelf.

De 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 !

• « Vorig Excel artikel
• Volgend Excel artikel »