【VBA】取得一组数据中排除离散值后的最大值及最小值

前言

一组数据，如果存在极端异常值，直接使用Excel公式去计算最大值与最小值是不靠谱的。
排除离散值后去计算才相对靠谱，但是Excel中又没有直接的公式，或者是需要套用多个很复杂的公式。这里我们采用VBA来实现。

一、准备数据，画个框框

二、编写代码

代码如下（示例）：

Sub FindMinMaxWithoutOutliers_DynamicRange()
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim lastRow As Long
    Dim Q1 As Double, Q3 As Double, IQR As Double
    Dim lowerBound As Double, upperBound As Double
    Dim maxValue As Variant, minValue As Variant
    Dim cell As Range
        
    ' 设置工作表
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' 更改为你的工作表名
    
    ws.Cells(1, 5) = ""
    ws.Cells(2, 5) = ""
    
    ' 动态获取数据区域的最后一行
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 假设数据在A列
    
    ' 设置动态数据范围
    Set dataRange = ws.Range("A2:A" & lastRow)
    
    ' 计算四分位数
    Q1 = Application.WorksheetFunction.Quartile_Exc(dataRange, 1)
    Q3 = Application.WorksheetFunction.Quartile_Exc(dataRange, 3)
    
    ' 计算IQR
    IQR = Q3 - Q1
    
    ' 定义离群值边界
    lowerBound = Q1 - 1.5 * IQR
    upperBound = Q3 + 1.5 * IQR
    
    ' 初始化最大值和最小值
    maxValue = Empty
    minValue = Empty
    
    ' 遍历数据，排除离群值并找到最大值和最小值
    For Each cell In dataRange
        If Not IsEmpty(cell.Value) Then
            If cell.Value >= lowerBound And cell.Value <= upperBound Then
                If IsEmpty(maxValue) Or cell.Value > maxValue Then
                    maxValue = cell.Value
                End If
                If IsEmpty(minValue) Or cell.Value < minValue Then
                    minValue = cell.Value
                End If
            End If
        End If
    Next cell
    
    ' 显示结果
    
    ws.Cells(1, 5) = maxValue
    ws.Cells(2, 5) = minValue
    
    MsgBox "计算完成", vbOKOnly, "提示"
    
End Sub

三、运行测试

右键给框框指定宏


点击框框运行

测试成功。

---

总结

采用VBA来取得一组数据中排除离散值后的最大值及最小值，一劳永逸，下一次再遇到这样的场景就会方便很多。