View Single Post
 
Old 07-18-2016, 04:53 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2016
Expert
 
Join Date: Aug 2014
Posts: 4,101
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Add the following code to an ordinary module:
Code:
Option Explicit

Sub AddTable()
Dim oTable As Table
Dim oRng As Range
Dim oCell As Range
Dim i As Long
    ActiveDocument.Tables(ActiveDocument.Tables.Count).Range.Copy
    Set oRng = ActiveDocument.Tables(ActiveDocument.Tables.Count).Range
    oRng.End = oRng.End + 1
    oRng.Collapse 0
    oRng.Text = vbCr
    oRng.Collapse 0
    oRng.Paste
    For i = 1 To ActiveDocument.Tables(ActiveDocument.Tables.Count).Range.Cells.Count
        ActiveDocument.Tables(ActiveDocument.Tables.Count).Range.Cells(i).Select
        Select Case i
            Case Is = 3, 4, 5, 8, 10, 12
                Set oCell = ActiveDocument.Tables(ActiveDocument.Tables.Count).Range.Cells(i).Range
                oCell.End = oCell.End - 1
                oCell.Text = ""
            Case Else
        End Select
    Next i
    ActiveDocument.Tables(ActiveDocument.Tables.Count).Range.Cells(3).Select
End Sub
Then modify your existing macro to call it
Code:
Private Sub Document_ContentControlOnEnter(ByVal CCtrl As ContentControl)
    Application.ScreenUpdating = False
    Dim CCtrlRng As Range, TblRng As Range, i As Long, Prot As Variant, Pwd As String
    With ActiveDocument
        Set CCtrlRng = CCtrl.Range
        If CCtrlRng.Information(wdWithInTable) Then
            Set TblRng = CCtrlRng.Tables(1).Range
            i = .Range(0, TblRng.End).Tables.Count
            If (i < 3) Then Exit Sub
            If MsgBox("Add new SBAR set?", vbQuestion + vbYesNo) = vbYes Then
                Prot = .ProtectionType
                If Prot <> wdNoProtection Then
                    Pwd = ""    'Insert password here
                    .Unprotect Password:=Pwd
                End If
                AddTable
                .Protect Type:=Prot, Password:=Pwd
            End If
        End If
    End With
    Application.ScreenUpdating = True
End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote