Automatic calculation of the average values in alternating columns.

dilshod_k · Jan 12th 2021

Hello everyone,

I’ve code (thanks to Saurabhjaina211), that inserts blanc columns between columns with data and makes calculations. I still have to manually make calculations of the average value at the bottom of the columns with percentage values. I was wandering if it is possible to automatically calculate average percentage of the values of the alternating columns with data in percentage format. The number of rows as well as number of columns are flexible, alternating columns start from column E. Would be grateful for any help.

P.S. Please find sample of the table as an attachment to this post.

Dilshod

Code

Sub TableResults()
'....
Dim colNo, colStart, colFinish, colStep As Long
Dim rng2Insert As Range
colStep = 2
colStart = Application.Cells(1, 4).Column + 1
colFinish = (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column * 2) - colStart
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For colNo = colStart To colFinish Step colStep
ActiveSheet.Cells(1, colNo).EntireColumn.Insert
'***New code inserted
ActiveSheet.Cells(1, colNo) = "Change%"
ActiveSheet.Columns(colNo).NumberFormat = "0.00%"
ActiveSheet.Cells(2, colNo) = "=(RC[-1]-RC[colNo-2])/RC[colNo-2]"
ActiveSheet.Cells(2, colNo).Columns(colNo).AutoFill
'***
Next
'***New code inserted
ActiveSheet.Cells(1, colNo) = "Change%"
ActiveSheet.Columns(colNo).NumberFormat = "0.00%"
'***
Dim colFinish2 As Integer, totalRows As Integer
colFinish2 = (ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column)
totalRows = WorksheetFunction.CountA(ActiveSheet.Range("B:B"))
On Error Resume Next
'Application.ScreenUpdating = False
For colNo = 5 To colFinish Step 2
With ActiveSheet
For rowno = 2 To totalRows
.Cells(rowno, colNo) = (.Cells(rowno, colNo - 1) - .Cells(rowno, 3)) / .Cells(rowno, 3)
Next
End With
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
End Sub

Display More

**KjBox** · Jan 12th 2021

The simplest solution is to use an Excel Built-in Table with a Totals Row rather than a manually created table.

dilshod_k · Jan 12th 2021

Quote from KjBox

The simplest solution is to use an Excel Built-in Table with a Totals Row rather than a manually created table.

This table is not created manually, the code published is part of the code that copies and transposes data from one table to another one, to simplify explanation I decided to publish part of the code. I know how to calculate totals in Excel for a single column, but I do not know how to do that for multiple alternating columns.

**KjBox** · Jan 13th 2021

What I meant by "manually created" was a table of data that was not in an Excel Built-in, the fact that code was used to make it makes no difference.

If, however you do not wish to use Excel Built-in Tables then this will remove any Total Averages that are already there and add new ones.

Code

Sub AverageTotals()
Dim x, y, i As Long, lRow As Long
With Sheet1.Cells(1).CurrentRegion
x = .Value
ReDim y(1 To UBound(x, 2))
For i = 5 To .Columns.Count Step 2
y(i) = Format(Application.Average(x(2, i), x(UBound(x, 1), i)), "0.00%")
Next
y(1) = "Total Averages"
If .Parent.Cells(UBound(x, 1), 1) = "Total Averages" Then lRow = UBound(x, 1) Else lRow = UBound(x, 1) + 1
.Parent.Rows(lRow).Clear
With .Parent.Cells(lRow, 1).Resize(, UBound(x, 2))
.Value = y
.Font.Bold = 1
End With
End With
End Sub

Display More

dilshod_k · Jan 13th 2021

Quote from KjBox

What I meant by "manually created" was a table of data that was not in an Excel Built-in, the fact that code was used to make it makes no difference.

If, however you do not wish to use Excel Built-in Tables then this will remove any Total Averages that are already there and add new ones.

Hi KjBox,

Thanks very much for your help. Though there might be an error in your formula as there is quite a big discrepancy between manually calculated averages (if we assume formula is =AVERAGE(E2:E361)) Excel calculation for the column E gives 3.79% and result of your VBA code is 8.85%, the same is with the rest of the column results. Thanks for your time anyway.

Dilshod

**KjBox** · Jan 13th 2021

Sorry my fault. Try changing the code to this

Code

Sub AverageTotals()
Dim x, y, z, i As Long, ii As Long, lRow As Long
With Sheet1.Cells(1).CurrentRegion
x = .Value
ReDim y(1 To UBound(x, 2))
ReDim z(1 To UBound(x, 1) - 1)
For i = 5 To .Columns.Count Step 2
For ii = 2 To UBound(x, 1) - 1
z(ii) = x(ii, i)
Next
y(i) = Format(Application.Average(z), "0.00%")
Next
y(1) = "Total Averages"
If .Parent.Cells(UBound(x, 1), 1) = "Total Averages" Then lRow = UBound(x, 1) Else lRow = UBound(x, 1) + 1
.Parent.Rows(lRow).Clear
With .Parent.Cells(lRow, 1).Resize(, UBound(x, 2))
.Value = y
.Font.Bold = 1
End With
End With
End Sub

Display More

dilshod_k · Jan 14th 2021

Hi KjBox,

Thanks a lot for your help! It works perfectly well. Obviously I would not be able to sort it out on my own.

Highly appreciate it.

Dilshod

**KjBox** · Jan 14th 2021

You're welcome. Thanks for the "Like"

dilshod_k · Jan 14th 2021

Quote from KjBox

You're welcome. Thanks for the "Like"

Hello KjBox,

Sorry its me again. It gives error message (Type mismatch, Line#12 of the code) with another seemingly identical table.

Is there any chance you could help me to figure out reason for that error?

Please find attached file with Sheet2.

Thanks in advance,

Dilshod

**KjBox** · Jan 14th 2021

The error is because the last column (Column AK) has no data for %Change.

I have included a bit of code to account for that.

Code

Sub AverageTotals()
Dim x, y, z, i As Long, ii As Long, lRow As Long
With Sheet2.Cells(1).CurrentRegion
x = .Value
ReDim y(1 To UBound(x, 2))
ReDim z(1 To UBound(x, 1) - 1)
For i = 5 To .Columns.Count Step 2
For ii = 2 To UBound(x, 1) - 1
z(ii) = x(ii, i)
Next
On Error Resume Next
y(i) = Format(Application.Average(z), "0.00%")
On Error GoTo 0
Next
y(1) = "Total Averages"
If .Parent.Cells(UBound(x, 1), 1) = "Total Averages" Then lRow = UBound(x, 1) Else lRow = UBound(x, 1) + 1
.Parent.Rows(lRow).Clear
With .Parent.Cells(lRow, 1).Resize(, UBound(x, 2))
.Value = y
.Font.Bold = 1
End With
End With
End Sub

Display More

dilshod_k · Jan 14th 2021

Thank you very much!

Appreciate it.

**KjBox** · Jan 14th 2021

You're welcome

Automatic calculation of the average values in alternating columns.

Share

Tags