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

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