Excel 2010, VBA and ListObjects subtotals not updating on Table changes

Question

So, having this structure (starting at A1 - show snippet > run):

table {
  border-color: #BBB;
  border-width: 0px 0px 1px 1px;
  border-style: dotted;
}
body {
  font: 12px Arial, Tahoma, Helvetica, FreeSans, sans-serif;
  color: #333;
}
td {
  border-color: #BBB;
  border-width: 1px 1px 0px 0px;
  border-style: dotted;
  padding: 3px;
}

<table>
  <tbody>
    <tr>
      <th></th>
      <th>A</th>
      <th>B</th>
      <th>C</th>
      <th>D</th>
    </tr>
    <tr>
      <td>1</td>
      <td>Title 1</td>
      <td>Title 2</td>
      <td>Title 3</td>
      <td>Title 4</td>
    </tr>
    <tr>
      <td>2</td>
      <td>GH</td>
      <td>1</td>
      <td>434</td>
      <td>4</td>
    </tr>
    <tr>
      <td>3</td>
      <td>TH</td>
      <td>3</td>
      <td>435</td>
      <td>5</td>
    </tr>
    <tr>
      <td>4</td>
      <td>TH</td>
      <td>4</td>
      <td>4</td>
      <td>6</td>
    </tr>
    <tr>
      <td>5</td>
      <td>LH</td>
      <td>2</td>
      <td>0</td>
      <td>3</td>
    </tr>
    <tr>
      <td>6</td>
      <td>EH</td>
      <td>2</td>
      <td>5</td>
      <td>36</td>
    </tr>
  </tbody>
</table>

I scripted some code to transform that range (A1:D6) in a ListObject, added 4 new columns and subtotals:

Function test()

    Dim objLO As ListObject

    Set objLO = ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$D$6"), , xlYes)
    objLO.Name = "Recap"
    objLO.TableStyle = "TableStyleMedium2"

    objLO.ListColumns.Add (objLO.ListColumns.Count + 1)
    objLO.HeaderRowRange(objLO.ListColumns.Count) = "Tot1"
    objLO.ListColumns.Add (objLO.ListColumns.Count + 1)
    objLO.HeaderRowRange(objLO.ListColumns.Count) = "Tot2"
    objLO.ListColumns.Add (objLO.ListColumns.Count + 1)
    objLO.HeaderRowRange(objLO.ListColumns.Count) = "Tot3"
    objLO.ListColumns.Add (objLO.ListColumns.Count + 1)
    objLO.HeaderRowRange(objLO.ListColumns.Count) = "Tot4"

    objLO.ShowTotals = True

    objLO.ListColumns("Tot1").TotalsCalculation = xlTotalsCalculationSum
    objLO.ListColumns("Tot2").TotalsCalculation = xlTotalsCalculationSum
    objLO.ListColumns("Tot3").TotalsCalculation = xlTotalsCalculationSum
    objLO.ListColumns("Tot4").TotalsCalculation = xlTotalsCalculationSum

End Function

Now if you go on any cell of the new columns and write some numbers the odd thing is that the TOTAL (subtotal) doesn't updates; but if you save the file and reopen it it would work and the totals will update. What I'm missing?

I've already tried moving the ShowTotals after the TotalCalculation but the behavior remain the same.

If we now rebuild the sheet from scratch and add this piece of code for subtotals for columns b, c and d after applying the style in the previous code:

objLO.ListColumns("b").TotalsCalculation = xlTotalsCalculationSum
objLO.ListColumns("c").TotalsCalculation = xlTotalsCalculationSum
objLO.ListColumns("d").TotalsCalculation = xlTotalsCalculationSum  

I noticed that the subtotals for b, c and d are working but not for Tot1, Tot2 etc.

It seems that the only workaround is to construct the raw table before adding a ListObject with the references for creating it. Anyone know a better solution?

Thanks in advance :)

Answer 1

There is an outstanding bug in Excel tables, and there are some subtleties that need to be addressed in order to get the outcome you require.

A crude fix using explicit calculation tricks does work, but while this approach will update the totals based on the current values in the data rows, they need to be applied every time there are changed values in the data table.

There are 2 ways to force Excel to calculate the totals:

1. You can toggle the Calculation state of the parent Worksheet:

   objLO.Parent.EnableCalculation = False
   objLO.Parent.EnableCalculation = True
   

2. Or, you can replace the = in the totals formulas:

   objLO.TotalsRowRange.Replace "=", "="
   

But neither of the above approaches give you a lasting solution that keeps the totals up to date automatically.

A better solution...

The clue to the solution lies in the fact that subtotals are dynamically calculated for columns that existed when the ListObject was converted from a range to a ListObject.

You can exploit this knowledge, and ensure that instead of appending columns to the end/right of the ListObject, you insert them before an existing column. But as you ultimately want the new columns to be right-most, this approach will require the use of a dummy column in the original range, then all new columns are inserted before the Dummy column, and finally, the Dummy column can be deleted.

See this modified code, with comments:

Function test()

    Dim objLO As ListObject

    'Expand the selection to grab an additional Dummy column
    Set objLO = ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$E$6"), , xlYes)
    objLO.Name = "Recap"
    objLO.TableStyle = "TableStyleMedium2"

    'Insert all of the new columns BEFORE the Dummy column
    objLO.ListColumns.Add (objLO.ListColumns.Count)
    objLO.HeaderRowRange(objLO.ListColumns.Count - 1) = "Tot1"
    objLO.ListColumns.Add (objLO.ListColumns.Count)
    objLO.HeaderRowRange(objLO.ListColumns.Count - 1) = "Tot2"
    objLO.ListColumns.Add (objLO.ListColumns.Count)
    objLO.HeaderRowRange(objLO.ListColumns.Count - 1) = "Tot3"
    objLO.ListColumns.Add (objLO.ListColumns.Count)
    objLO.HeaderRowRange(objLO.ListColumns.Count - 1) = "Tot4"

    'Must show totals BEFORE applying totals, otherwise the last column defaults to Count (even if we override it)
    objLO.ShowTotals = True

    objLO.ListColumns("Tot1").TotalsCalculation = xlTotalsCalculationSum
    objLO.ListColumns("Tot2").TotalsCalculation = xlTotalsCalculationSum
    objLO.ListColumns("Tot3").TotalsCalculation = xlTotalsCalculationSum
    objLO.ListColumns("Tot4").TotalsCalculation = xlTotalsCalculationSum

    'Remove the extra dummy column
    objLO.ListColumns(objLO.ListColumns.Count).Delete

    'Now toggle the ShowTotals to force the ListObject to recognise the new column totals
    objLO.ShowTotals = False
    objLO.ShowTotals = True

End Function