The following macro automates the row-wise merging of cells spanning multiple selected columns & rows in a table. As coded, the macro performs row-wise merging of only the selected cells. Comments in the code show how to adapt it for row-wise merging of all cells to the right of the first selected one and/or to the bottom of the table without having to select all those cells beforehand.
Code:
Sub RowMerge()
Application.ScreenUpdating = False
Dim r As Long, c As Long, x As Long, y As Long
With Selection
If .Information(wdWithInTable) = True Then
'For all columns right of the selected cell, delete/comment-out the next line:
If .Columns.Count < 2 Then GoTo ErrExit
c = .Cells(1).ColumnIndex
x = c - 1 + .Columns.Count
'For all columns right of the selected cell, use:
'x = .Tables(1).Columns.count
r = .Cells(1).RowIndex
y = r - 1 + .Rows.Count
'For all rows below the selected cell, use:
'y = .Tables(1).Rows.count
With .Tables(1)
For r = r To y
.Cell(r, c).Merge .Cell(r, x)
Next
End With
Else
ErrExit:
MsgBox "Please select cells in the columns to process, then try again", vbInformation
End If
End With
Application.ScreenUpdating = True
End Sub
The following macro automates the column-wise merging of cells spanning multiple selected columns & rows in a table. As coded, the macro performs column-wise merging of only the selected cells. Comments in the code show how to adapt it for column-wise merging of all cells to the right of the first selected one and/or to the bottom of the table without having to select all those cells beforehand.
Code:
Sub ColMerge()
Application.ScreenUpdating = False
Dim r As Long, c As Long, x As Long, y As Long
With Selection
If .Information(wdWithInTable) = True Then
'For all rows below the selected cell, delete/comment-out the next line:
If .Rows.Count < 2 Then GoTo ErrExit
c = .Cells(1).ColumnIndex
x = c - 1 + .Columns.Count
'For all columns right of the selected cell, use:
'x = .Tables(1).Columns.count
r = .Cells(1).RowIndex
y = r - 1 + .Rows.Count
'For all rows below the selected cell, use:
'y = .Tables(1).Rows.count
With .Tables(1)
For c = c To x
.Cell(r, c).Merge .Cell(y, c)
Next
End With
Else
ErrExit:
MsgBox "Please select cells in the rows to process, then try again", vbInformation
End If
End With
Application.ScreenUpdating = True
End Sub