Question

早上好，我正在寻找创建一个VBA宏，该宏将遍历包含数据的列的数量，然后使用trimmean数组计算平均值，以排除所有低于零的值以及上限和下限数据的10％。我已经构建了VBA脚本的其他部分，但是我不确定如何使普通部分正常工作。我已经获得了vba代码来对10％的数据执行trimmean函数，但是我无法将仅取零以上的值纳入其中。任何帮助表示赞赏。

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

Answer 1

我能使它起作用的唯一方法是一种变通方法，即我将所有大于零的值加载到数组中，然后从中获取百分位数。

然后您对范围进行测试，以得到一个总和，其中所有值均不大于90％，小于10％且不小于零。

一旦有了该总和，就可以将其除以计数器，得出本质上的均值：

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 2

似乎正在添加用户定义的函数并将其应用于过程。

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

将其应用于过程。

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

用Trimmean平均列的动态范围

2 个答案: