Sub NewMultiRow()
Dim pTable As Word.Table
Dim bValid As Boolean
Dim curCursor As Long
Dim bCalcField As Boolean
Dim oRng1 As Word.Range
Dim oRng2 As Word.Range
Dim userInput As String
Dim rowsToAdd As Long
Dim rowAdd As Long
Dim oFF As Word.FormField
Dim oRowID As Long
Dim i As Long
Dim pNewName As String
Dim pNameSeparator As Long
Dim pRowIndex
Dim oBmName As String
Set pTable = ActiveDocument.Tables(1) 'As appropriate
             'Use Selection.Tables(1) if executing with an on exit macor
'Get user input of rows to add
bValid = False
Do
  userInput = InputBox("Enter number of rows to add", "Add Rows", 1)
  If userInput = vbNullString Then Exit Sub
  If userInput = "0" Then Exit Sub
  If IsNumeric(userInput) Then rowsToAdd = CLng(userInput)
  If rowsToAdd > 0 Then bValid = True
  If Not bValid Then
    MsgBox "You must use a positve numeric input e.g." & Chr(34) & "3" & Chr(34)
  End If
Loop Until bValid
'Minimize screen flicker
curCursor = System.Cursor
System.Cursor = wdCursorWait
Application.ScreenUpdating = False
'Determine if calculation fields are present and set a flag
On Error GoTo Err_Handler
Set oRng1 = pTable.Rows(pTable.Rows.Count - 2).Range '2 accounts for the trailing rows
bCalcField = False
For i = 1 To oRng1.FormFields.Count
  If oRng1.FormFields(i).TextInput.Type = wdCalculationText Then
    bCalcField = True
    Exit For
  End If
Next i
'Unprotect document.
If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
  ActiveDocument.Unprotect
End If
'Add individual rows
For rowAdd = 1 To rowsToAdd
  Set oRng1 = pTable.Rows(pTable.Rows.Count - 2).Range
  Set oRng2 = oRng1.Duplicate
  With oRng1
    .Copy
    .Collapse Direction:=wdCollapseEnd
    .Paste
  End With
  For i = 1 To oRng1.FormFields.Count
    oRowID = pTable.Rows.Count - 4 '4 accounts for the two leading and two
                                   'trailing.
    'Build and assign formfield bookmark names
    oRng1.FormFields(i).Select
    'Build new name
    pNewName = oRng2.FormFields(i).Name
    pNameSeparator = InStr(pNewName, "_Row")
    If pNameSeparator > 0 Then
      pNewName = Left(pNewName, pNameSeparator - 1)
    End If
    'Prevent assigning an existing bookmark name
    If ActiveDocument.Bookmarks.Exists(pNewName & "_Row" & oRowID) Then
      MsgBox "Invalid action.  A form field with the bookmark name " _
           & pNewName & "_" & oRowID _
           & " already appears this table.  Exiting this procedure."
      pTable.Rows(oRowID).Delete
      ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
      Exit Sub
    End If
      With Dialogs(wdDialogFormFieldOptions)
      .Name = pNewName & "_Row" & oRowID
      'Assign valid bookmark name to new formfield
      .Execute
    End With
    'This code could be used to clear previous on exit macros if used.
    'If oRng2.FormFields(i).ExitMacro = "NewMultiRow" Then
    '  oRng2.FormFields(i).ExitMacro = ""
    'End If
  Next
  'Call subroutine to build new calculation field
  If bCalcField Then
    BuildNewCalcFieldExpressions oRng1, oRng2
  End If
Next
pRowIndex = pTable.Rows.Count - rowsToAdd + 1 - 2 '2 accounts for the 2 trailing rows
oBmName = pTable.Rows(pRowIndex).Cells(1).Range.Bookmarks(1).Name
ActiveDocument.Bookmarks(oBmName).Range.Fields(1).Result.Select
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
'Restore visuals
Application.ScreenUpdating = True
System.Cursor = curCursor
Exit Sub
Err_Handler:
If Err.Number = 5991 Then
  MsgBox Err.Description
Else
  MsgBox "Unknown error."
End If
End Sub
Sub BuildNewCalcFieldExpressions(ByVal oRng1 As Range, oRng2 As Range)
'Construct any new calculation fields.  Credit for this section goes to fellow
'MVP Tony Jollans
Dim oFF As FormField
Dim strOldVar As String
Dim strNewVar As String
Dim strNewCalc As String
Dim ndx As Long
Dim ndx2 As Long
Dim lngVarPosit  As Long
Dim lngVarNextPosit  As Long
Dim bVariableFound As Boolean
Dim bVariableReplace As Boolean
For ndx = 1 To oRng1.FormFields.Count
  Set oFF = oRng1.FormFields(ndx)
  If oFF.Type = wdFieldFormTextInput Then
    If oFF.TextInput.Type = wdCalculationText Then
      strNewCalc = oFF.TextInput.Default
      For ndx2 = 1 To oRng2.FormFields.Count
        strOldVar = oRng2.FormFields(ndx2).Name
        lngVarPosit = 1
        Do While lngVarPosit > 0
          lngVarPosit = InStr(lngVarPosit, strNewCalc, strOldVar)
          bVariableFound = lngVarPosit > 0
          bVariableReplace = bVariableFound
          If bVariableReplace Then
            If lngVarPosit > 1 Then
              If Mid$(strNewCalc, lngVarPosit - 1) Like "[0-9A-Z_a-z]" Then
                bVariableReplace = False
              End If
            End If
          End If
          If bVariableReplace Then
            lngVarNextPosit = lngVarPosit + Len(strOldVar)
            If lngVarNextPosit <= Len(strNewCalc) Then
              If Mid$(strNewCalc, lngVarNextPosit) Like "[0-9A-Z_a-z]" Then
                bVariableReplace = False
              End If
            End If
          End If
          If bVariableReplace Then
            strNewVar = oRng1.FormFields(ndx2).Name
            strNewCalc = Left$(strNewCalc, lngVarPosit - 1) & strNewVar & Mid$(strNewCalc, lngVarNextPosit)
            lngVarPosit = lngVarPosit + Len(strNewVar)
          Else
            If bVariableFound Then
              lngVarPosit = lngVarPosit + Len(strOldVar)
            End If
          End If
        Loop
      Next ndx2
      oFF.Select
      With Dialogs(wdDialogFormFieldOptions)
        .TextDefault = strNewCalc
        .Execute
      End With
    End If
  End If
Next ndx
End Sub