Macro to add rows to a table with calculations

Anonymous
2018-11-07T01:19:33+00:00

In  Word 2016, within a locked form, I have a table with five rows and seven columns.

Row 1 is the title of the table and is all seven columns merged.

Row 2 is the titles of all columns, with columns 1 and 2 merged.

Row 3 is for the user to input text in columns 1 and 2, there's a dropdown in column 3, dollar values are input in columns 4 and 5, column 6 automatically calculates the GST from the dollar value in column 5 and column 7 automatically gives the total of columns 5 and 6.

Row 4 is for user input in column 2 only and carries the macro to add additional rows if required upon exit of the field.

Row 5 is the totals of each column 4 to 7.  In order for Word to calculate the totals in row 5, rows 3 and 4 are merged in columns 3 to 7 - I used =SUM(ABOVE) in each column.

If the user needs to add additional rows, the code required to ensure:

.  Rows 3 and 4 are duplicated, with all fields cleared and the dropdown in column 3 showing the first option;

.  The calculations in columns 6 and 7 work for the new row;

.  The totals in the current row 5 still add up;

.  After the extra rows have been added, the cursor is sitting on the first field in the "new" row 3 (which would, in effect, now be row 5);

is well and truly beyond me.

I have used legacy form fields throughout.

Can someone please help?

Microsoft 365 and Office | Word | For home | Windows

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments
Answer accepted by question author
Paul Edstein 82,871 Reputation points Volunteer Moderator
2018-11-16T05:22:52+00:00

As per my previous reply, you need to set the 'calculate on exit' property for the 'Claimed amount' and 'Payment amount' formfields. You don't need it on any others.

Was this answer helpful?

0 comments
Answer accepted by question author
Anonymous
2018-11-07T04:20:29+00:00

That box is a UserForm and is for the start.

Here are the macros I use for the tables.

[code]Sub AddTimeRow()
'
' AddTimeRow Macro
' Macro written 12/01/2003 by Charles Kyle Kenyon
' Revised 01/16/2004 by Charles Kyle Kenyon
' Additional comments added 04/28/2006 by Charles Kyle Kenyon
'
'   Triggered by F2 key
'
    UnprotectDocumentMacro
    Dim sTime As String
    sTime = ActiveDocument.Bookmarks("TotalIn").Range.Text
    If sTime = "0.0" Then
        sTime = ActiveDocument.Bookmarks("TotalOut").Range.Text
        If sTime = "0.0" Then
            ActiveDocument.Bookmarks("TimeTitle").Select
            ProtectDocumentMacro
            Exit Sub
        End If
    End If
'   sTime section is checking for zero totals in table. The two places there that could hold a total are bookmarked. It checks the contents of those bookmarks. If they are both 0.0, then it goes to a bookmark in the table header which is not a form field and reprotects the table. This acts to select the first formfield in the table.
'
'   Unprotected document
'
'
    Application.ScreenUpdating = False
    Dim oTemplate As Template
    Set oTemplate = Templates(ThisDocument.FullName)
    With Selection
        .GoTo What:=wdGoToBookmark, Name:="Total1"
        .MoveUp Unit:=wdLine, Count:=1
    #If VBA6 Then
        '   Procedure for later versions
        .InsertRowsBelow 1
        .HomeKey Unit:=wdLine
    #Else
        '   Procedure for Word 97
        .InsertRows 1
        .HomeKey Unit:=wdLine
        .MoveDown Unit:=wdLine, Count:=1
        .HomeKey Unit:=wdLine
        .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        .Extend
        .EndKey Unit:=wdLine
        .MoveRight Unit:=wdCharacter, Count:=3
        .Copy
        .Delete Unit:=wdCharacter, Count:=1
        .MoveUp Unit:=wdLine, Count:=1
        .Paste
        .MoveDown Unit:=wdLine, Count:=1
    #End If
'        oAutoText("TimeLine").Insert
'
'   Then it does the AutoCorrect settings - not sure why.
'
        Application.DisplayAutoCompleteTips = True
        With AutoCorrect
            .CorrectInitialCaps = True
            .CorrectSentenceCaps = True
            .CorrectDays = True
            .CorrectCapsLock = True
            .ReplaceText = True
        End With
'   Then insert, one by one, the AutoText entries for each cell in the row. Finally, it moves back to the beginning of the row and reprotect's the document. This selects the form field at the beginning of the new row.
        oTemplate.AutoTextEntries("zDateField").Insert Where _
            :=.Range
        .MoveRight Unit:=wdCell
        oTemplate.AutoTextEntries("zTimeDescription").Insert _
             Where:=.Range
        .MoveRight Unit:=wdCell
        oTemplate.AutoTextEntries("zTimeOutOfCourt").Insert _
            Where:=.Range
        .MoveRight Unit:=wdCell
        oTemplate.AutoTextEntries("zTimeInCourt").Insert _
            Where:=.Range
        .MoveLeft Unit:=wdCell
        .MoveLeft Unit:=wdCell
        .MoveLeft Unit:=wdCell
    End With
    Application.ScreenUpdating = True
    Application.ScreenRefresh
    ProtectDocumentMacro
End Sub
Sub InsertRowAboveMe()
'
' InsertRowAboveMe Macro
' Macro written 12/01/03 by Charles Kyle Kenyon
'
'   Unprotect document
    UnprotectDocumentMacro
'
'
    Dim sAutoTextEntry1 As String
    Dim sAutoTextEntry2 As String
    Dim oTemplate As Template
    Set oTemplate = Templates(ThisDocument.FullName)
'
    With Selection
        .SelectRow
'       Test for Table 2
'       -------------------------Table 2 - Time -----------------
        If ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count = 2 Then
'           Test for time row (4 columns)
            If .Columns.Count = 4 Then
'
''           Add row if in a table
'            If Selection.Information(wdWithInTable) = True Then
'                Selection.Rows.Add BeforeRow:=Selection.Rows(1)
'            End If
                .InsertRows 1
                .HomeKey Unit:=wdLine
                Application.DisplayAutoCompleteTips = True
                With AutoCorrect
                    .CorrectInitialCaps = True
                    .CorrectSentenceCaps = True
                    .CorrectDays = True
                    .CorrectCapsLock = True
                    .ReplaceText = True
                End With
                oTemplate.AutoTextEntries("zDateField").Insert Where _
                    :=.Range
                .MoveRight Unit:=wdCell
                oTemplate.AutoTextEntries("zTimeDescription").Insert _
                     Where:=.Range
                .MoveRight Unit:=wdCell
                oTemplate.AutoTextEntries("zTimeOutOfCourt").Insert _
                    Where:=.Range
                .MoveRight Unit:=wdCell
                oTemplate.AutoTextEntries("zTimeInCourt").Insert _
                    Where:=.Range
                .MoveLeft Unit:=wdCell
                .MoveLeft Unit:=wdCell
                .MoveLeft Unit:=wdCell
            End If  '   4 Columns
        End If  '   Table 2
        '
'       Test for Table 3
'       -------------------------Tables 3 & 4 - Disbursements ----------------------
        If ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count > 2 Then
            If ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count = 3 Then
                sAutoTextEntry1 = "zExpenseDescription"
                sAutoTextEntry2 = "zExpenseAmount"
            Else    '   Table 4 - Payments
                sAutoTextEntry1 = "zPaymentDescription"
                sAutoTextEntry2 = "zPaymentAmount"
            End If
'           Test for entry row (3 columns)
            If .Columns.Count = 3 Then
'
''           Add row if in a table
'            If Selection.Information(wdWithInTable) = True Then
'                Selection.Rows.Add BeforeRow:=Selection.Rows(1)
'            End If
                .InsertRows 1
                .HomeKey Unit:=wdLine
                Application.DisplayAutoCompleteTips = True
                With AutoCorrect
                    .CorrectInitialCaps = True
                    .CorrectSentenceCaps = True
                    .CorrectDays = True
                    .CorrectCapsLock = True
                    .ReplaceText = True
                End With
                oTemplate.AutoTextEntries("zDateField").Insert Where _
                    :=.Range
                .MoveRight Unit:=wdCell
                oTemplate.AutoTextEntries(sAutoTextEntry1).Insert _
                     Where:=.Range
                .MoveRight Unit:=wdCell
                oTemplate.AutoTextEntries(sAutoTextEntry2).Insert _
                    Where:=.Range
                .MoveLeft Unit:=wdCell
                .MoveLeft Unit:=wdCell
            End If  '   3 Columns
        End If  '   Table 3
        
    End With    '   Selection
    ProtectDocumentMacro
End Sub
Sub AddExpenseRow()
'
' AddExpenseRow Macro
' Macro written 11/18/2003 by Charles Kyle Kenyon
'
    UnprotectDocumentMacro
    If ActiveDocument.Bookmarks("Disbursements").Range.Text = "$ 0.00" Then
        ActiveDocument.Bookmarks("DisbursementsTitle").Select
        ProtectDocumentMacro
        Exit Sub
    End If
'    #If VBA6 Then
'        With Selection
'            .GoTo What:=wdGoToBookmark, Name:="Total2"
'            .MoveUp Unit:=wdLine, Count:=1
'            '
'            '   Procedure for later versions
'            .InsertRowsBelow 1
'            .HomeKey Unit:=wdLine
'            .MoveRight Unit:=wdCell
'            .MoveRight Unit:=wdCell
'            .TypeText Text:="0.00"
'            .MoveLeft Unit:=wdCell
'            .MoveLeft Unit:=wdCell
'        End With
'        NoBorders
'    #Else
        AddRow97 (3)
'    #End If
    ProtectDocumentMacro
End Sub
Sub AddPaymentRow()
'
' AddPaymentRow Macro
' Macro written 11/18/2003 by Charles Kyle Kenyon
'
    UnprotectDocumentMacro
    If ActiveDocument.Bookmarks("Payments").Range.Text = "$ 0.00" Then
        ActiveDocument.Bookmarks("PaymentsCreditsTitle").Select
        ProtectDocumentMacro
        Exit Sub
    End If
'    #If VBA6 Then
'        With Selection
'            .GoTo What:=wdGoToBookmark, Name:="Payments"
'            .MoveUp Unit:=wdLine, Count:=1
'            .InsertRowsBelow 1
'            .HomeKey Unit:=wdLine
'            .MoveRight Unit:=wdCell
'            .MoveRight Unit:=wdCell
'            .TypeText Text:="0.00"
'            .MoveLeft Unit:=wdCell
'            .MoveLeft Unit:=wdCell
'        End With
'        NoBorders
'    #Else
        AddRow97 (4)
'    #End If
    ProtectDocumentMacro
End Sub
Sub UpdateTotals()
'
' UpdateTotals Macro
' Macro written 11/18/2003 by Charles Kyle Kenyon
'
    UnprotectDocumentMacro
'    ActiveDocument.Tables(5).Select
'    With Selection
'        .Fields.Update
'        .Fields.Update
''        CheckDisbursements ' If hidden and not empty, unhide
'        .GoTo What:=wdGoToBookmark, Name:="Balance"
'        .MoveLeft Unit:=wdCell
'        .Collapse
'    End With
    ActiveDocument.Bookmarks("SummaryTable").Range.Fields.Update
    ActiveDocument.Bookmarks("BalanceTopRow").Range.Fields.Update
    ProtectDocumentMacro
End Sub
Private Sub NoBorders()
'
' NoBorders Macro
' Macro written 11/19/2003 by Charles Kyle Kenyon
'
    Selection.MoveRight Unit:=wdCharacter, Count:=3, Extend:=wdExtend
    With Selection.Cells
        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        .Borders(wdBorderRight).LineStyle = wdLineStyleNone
        .Borders(wdBorderTop).LineStyle = wdLineStyleNone
        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
        .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
        .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
    End With
    Selection.HomeKey Unit:=wdLine
End Sub
Sub ShowHideDisbursements()
'
' ShowHideDisbursements Macro
' Macro written 11/24/03 by Charles Kyle Kenyon
' Toggles printing of disbursements category (Table 3)
'
    UnprotectDocumentMacro
    With Selection
        .GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=3, Name:=""
        .MoveUp Unit:=wdLine, Count:=1
        .EndKey Unit:=wdLine
        .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        .Extend
        .GoTo What:=wdGoToBookmark, Name:="Disbursements"
        .Font.Hidden = wdToggle
        With .Find
            .ClearFormatting
            With .Font
                .Name = "Comic Sans MS"
                .Hidden = False
            End With
            .Replacement.ClearFormatting
            With .Replacement.Font
                .Name = "Comic Sans MS"
                .Hidden = True
            End With
            .Text = ""
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
            .ClearFormatting
            .Replacement.ClearFormatting
        End With
'        .GoTo What:=wdGoToBookmark, Name:="DisbursementsSummary"
'        .Font.Hidden = wdToggle
        .GoTo What:=wdGoToBookmark, Name:="Disbursements"
        .HomeKey Unit:=wdLine
        .MoveUp Unit:=wdLine, Count:=1
    End With
    ProtectDocumentMacro
End Sub
'

Private Sub AddRow97(Optional lTable As Long = 2)
'
' AddRow97 Macro
' Macro recorded 11/24/03 by Charles Kyle Kenyon
'
    Dim oTemplate As Template
    Set oTemplate = Templates(ThisDocument.FullName)
    Dim sAutoTextEntry1 As String
    Dim sAutoTextEntry2 As String
    If lTable = 3 Then
        sAutoTextEntry1 = "zExpenseDescription"
        sAutoTextEntry2 = "zExpenseAmount"
    Else    '   Table 4 - Payments
        sAutoTextEntry1 = "zPaymentDescription"
        sAutoTextEntry2 = "zPaymentAmount"
    End If
'
    Dim lRowCount As Long
    Dim rRow As Range
    UnprotectDocumentMacro
'
    lRowCount = ActiveDocument.Range.Tables(lTable).Rows.Count
    ActiveDocument.Tables(lTable).Rows(lRowCount - 1).Select
    With Selection
        .Copy
        .Paste
        ActiveDocument.Tables(lTable).Rows(lRowCount).Select
        .Delete Unit:=wdCharacter, Count:=1
        .HomeKey Unit:=wdLine
        Application.DisplayAutoCompleteTips = True
        With AutoCorrect
            .CorrectInitialCaps = True
            .CorrectSentenceCaps = True
            .CorrectDays = True
            .CorrectCapsLock = True
            .ReplaceText = True
        End With
        oTemplate.AutoTextEntries("zDateField").Insert Where _
            :=.Range
        .MoveRight Unit:=wdCell
        oTemplate.AutoTextEntries(sAutoTextEntry1).Insert _
             Where:=.Range
        .MoveRight Unit:=wdCell
        oTemplate.AutoTextEntries(sAutoTextEntry2).Insert _
            Where:=.Range
        .MoveLeft Unit:=wdCell
        .MoveLeft Unit:=wdCell
        ActiveDocument.Tables(lTable).Rows(lRowCount).Select
        With .Cells
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderTop).LineStyle = wdLineStyleNone
            .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
            .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
            .Borders.Shadow = False
        End With    '   .Cells
    End With    '   Selection
    ActiveDocument.Range.Tables(lTable).Rows(lRowCount).Select
    Selection.HomeKey Unit:=wdLine
    ProtectDocumentMacro
End Sub

Private Sub CheckDisbursements()
    Dim lAmount As Variant
    Dim rAmount As Range
    Set rAmount = ActiveDocument.Bookmarks("Disbursements").Range
    lAmount = rAmount.Text
'    MsgBox Prompt:=lAmount
    If lAmount <> "$ 0.00" Then
        If rAmount.Font.Hidden = True Then
            ShowHideDisbursements
            MsgBox Prompt:="FYI: There is an amount (" & lAmount _
                & ") in Disbursements." _
                & vbCrLf & "Disbursements will print.", _
                Title:="Disbursements Included in Totals"
        End If
    End If
End Sub

Sub FontsBigger()
    UnprotectDocumentMacro
    ActiveDocument.Styles("Body Text,bt,bt1").Font.Size = 12
    ActiveDocument.Styles("Heading 2").Font.Size = 12
    ActiveDocument.Styles("Subtitle").Font.Size = 14
    ProtectDocumentMacro
End Sub
Sub FontsSmaller()
    UnprotectDocumentMacro
    ActiveDocument.Styles("Body Text,bt,bt1").Font.Size = 10
    ActiveDocument.Styles("Heading 2").Font.Size = 10
    ActiveDocument.Styles("Subtitle").Font.Size = 13
    ProtectDocumentMacro
End Sub

Sub UnprotectDocumentMacro()
'   Unprotect document
    If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
      ActiveDocument.Unprotect
    End If
End Sub

Sub ProtectDocumentMacro()
    If ActiveDocument.ProtectionType <> wdAllowOnlyFormFields Then
        ActiveDocument.Protect Type:=wdAllowOnlyFormFields, noreset:=True
    End If
End Sub
[/code]

Note especially the Protect and Unprotect Document macros and the ones to change the font size.

In my template those have attached keyboard shortcuts. They could also be on QAT modifications or even a custom ribbon tab.

Was this answer helpful?

0 comments

30 additional answers

Sort by: Most helpful
Most helpful Newest Oldest
  1. Anonymous
    2018-11-07T02:24:45+00:00

    I can't do it the way your document looks - all I need is for Word to reference the "new" rows and do the calculations in those rows.  The user needs to be filling in the fields in the table, not in a separate box, as you have pictured.

    Was this answer helpful?

    0 comments
  2. Paul Edstein 82,871 Reputation points Volunteer Moderator
    2018-11-07T01:53:25+00:00

    Was this answer helpful?

    0 comments
  3. Anonymous
    2018-11-07T01:42:44+00:00

    Hi,

    It has been a while since I've done this. I have a billing form that I use that does this. i will try to dig out how i got it to work.

    I hope this information helps. Please let me know if you have any more questions or require further help.

    Regards

    Was this answer helpful?

    0 comments