Таблицы: Добавление колонок слева и справа в таблицы со слитыми ячейками

VBA-addict, активный участник нашего форума, предложил свое решение по таблицам. Публикую это решение также и здесь. Вопросы можете задавать автору заметки как в комментариях, так и на форуме.

При попытке добавления в таблицу со слитыми ячейками колонок слева и справа часто возникают проблемы связанные с тем, что ячейкам колонки присваивается ширина соседних ячеек. Соответственно, если ширина у них разная - таблица разлетается в столбчатую диаграмму.

Не найдя полностью готового решения в сети скомпилировал свое. Работает на текущей таблице под курсором.

Для добавления слева и справа код несколько отличается, т.к. при добавлении слева всегда ссылка идет на первую ячейку строки, которая есть всегда, а справа - на последнюю, номер которой может отличаться из-за слитых ячеек.

Sub AddCol2LeftMergedCTable()
    If Selection.Range.Information(wdWithInTable) = False Then Exit Sub
    With Selection.Tables(1)
        TblRowsNumber = .Rows.Count        
        NewColumnWidth = InputBox$("Enter the width in millimeters for the Column to add", _
                                   "Add column to the LEFT for a table with merged cells", _
                                   NewColumnWidth)
        If Val(NewColumnWidth) = 0 Then Exit Sub
        For i = 1 To TblRowsNumber
            .Range.Cells.Add BeforeCell:=.Cell(i, 1)
            .Cell(i, 1).Width = MillimetersToPoints(NewColumnWidth)
        Next
    End With
    Selection.MoveDown
End Sub

Sub AddCol2RightMergedCTable()
    If Selection.Range.Information(wdWithInTable) = False Then Exit Sub
    With Selection.Tables(1)
        TblRowsNumber = .Rows.Count
        NewColumnWidth = InputBox$("Enter the Width in millimeters" & vbCrLf & "for the Column to add", _
                                   "Add column to the RIGHT for a table with merged cells", _
                                   NewColumnWidth)
        If Val(NewColumnWidth) = 0 Then Exit Sub        
        For i = 1 To TblRowsNumber
            LastColNum = .Rows(i).Cells.Count
            .Rows(i).Cells(LastColNum).Select
            Selection.MoveRight
            Selection.InsertCells ShiftCells:=wdInsertCellsShiftRight 'добавляем ячейку'
            Selection.Cells.Width = NewColumnWidth
        Next
    End With
    Selection.MoveDown
End Sub

Обсудить (1)

Таблицы в колонтитулах для блондинок

Инструкция по созданию рамок в колонтитулах для сдачи сдачи проектной документации согласно ГОСТ Р 21.1101-2009.

Скачать рамки А4 А3 книжный, альбомный формат и шрифт GOST type A.