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