Home » excel » excel – Averaging Dynamic range of Columns with Trimmean

# excel – Averaging Dynamic range of Columns with Trimmean

Posted by: admin May 14, 2020 Leave a comment

Questions:

Good morning, I am looking to create a VBA macro that will go through the amount of columns that contain data, and then calculate the average using a trimmean array to exclude all the values that are below zero and also the upper and lower 10% of the data. I have the other parts of my VBA script built, I just am not sure how to get the average part to work. I have gotten the vba code to do the trimmean function with 10% of the data, but I have not been able to incorporate the aspect of only taking values above zero. Any help is appreciated.

``````Sub columnFormulas()

Sheets.Add.Name = "Avg"

Worksheets("Sheet1").Activate
Set wsOut = Worksheets("Avg")
Set myRange = Application.InputBox("Select srange", "Range", , , , , , 8)

colCount = myRange.Columns.Count
Application.ScreenUpdating = False
With wsOut
.Activate
For counter = 1 To colCount
'.Cells(2, counter).Value = WorksheetFunction.StDev(myRange.Columns(counter))
.Cells(1, counter).Value = WorksheetFunction.TrimMean(myRange.Columns(counter), 0.1)
Next counter
End With
Application.ScreenUpdating = True

Worksheets("Avg").Columns("A:Z").AutoFit
End Sub
``````
How to&Answers:

The only way I could get this to work would be with a workaround where I load all values that are greater than zero into an array, then get the percentiles from that.

Then you test against your range to get a sum where all values are not greater than the 90th percentile, less than the 10 percentile, and not less than zero.

Once you have that sum, you can divide it by the counter to get essentially, the mean:

``````Sub columnFormulas()

Dim sumval As Long, i As Long, upperpercentile As Long, lowerpercentile As Long
Dim myarr As Variant
Dim cell As Range

sumval = 0
i = 0
ReDim myarr(0 To 0)

Sheets.Add.Name = "Avg"

Worksheets("Sheet1").Activate
Set wsOut = Worksheets("Avg")
Set myRange = Application.InputBox("Select srange", "Range", , , , , , 8)

colCount = myRange.Columns.Count
Application.ScreenUpdating = False

With wsOut
.Activate

For Each cell In myRange.Columns(counter)
If Not cell.Value <= 0 Then
myarr(i) = cell.Value
ReDim Preserve myarr(0 To i + 1)
i = i + 1
End If
Next cell

upperpercentile = WorksheetFunction.Percentile(myarr, 0.9)
lowerpercentile = WorksheetFunction.Percentile(myarr, 0.1)

For Each cell In myRange.Columns(counter)
If Not cell.Value >= upperpercentile And _
Not cell.Value <= lowerpercentile And _
Not cell.Value <= 0 Then
sumval = sumval + cell.Value
counter = counter + 1
End If
Next cell

.Cells(1, counter).Value = sumval / counter
End With
Application.ScreenUpdating = True

Worksheets("Avg").Columns("A:Z").AutoFit
End Sub
``````

### Answer：

It seems to be adding a user-defined function and applying it to the procedure.

``````Function TrimMeanX(rngDB As Range, p As Single)
Dim vR()
Dim n As Long
For Each Rng In rngDB
If Rng > 0 Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = Rng
End If
Next Rng
TrimMeanX = WorksheetFunction.TrimMean(vR, p)
End Function
``````

Applying it to procedure.

``````Sub columnFormulas()

Sheets.Add.Name = "Avg"

Worksheets("Sheet1").Activate
Set wsOut = Worksheets("Avg")
Set myRange = Application.InputBox("Select srange", "Range", , , , , , 8)

colCount = myRange.Columns.Count
Application.ScreenUpdating = False
With wsOut
.Activate
For counter = 1 To colCount
'.Cells(2, counter).Value = WorksheetFunction.StDev(myRange.Columns(counter))
.Cells(1, counter).Value = TrimMeanX(myRange.Columns(counter), 0.1) '<~~ apply UDF
Next counter
End With
Application.ScreenUpdating = True

Worksheets("Avg").Columns("A:Z").AutoFit
End Sub
``````