【Excel VBA编程】按区间统计数据:区间也能“自定义”,你的区间范围你来定

Sub CountDataByIntervalToColumnE()    Dim ws As Worksheet    Dim lastRowB As Long, lastRowD As Long    Dim i As Long, j As Long    Dim dataValue As Double    Dim intervalStr As String    Dim lowerBound As Double, upperBound As Double    Dim intervalDict As Object    Dim outputRow As Long    Dim key As Variant    ' 设置要操作的工作表，这里使用活动工作表    Set ws = ActiveSheet    ' 创建字典对象用于存储每个区间及其对应的计数    Set intervalDict = CreateObject("Scripting.Dictionary")    ' 获取B列和D列的最后一行数据行号    lastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row    lastRowD = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row    '初始化区间字典。遍历D列，将每个区间字符串作为键，计数值初始化为0    For i = 2 To lastRowD        intervalStr = Trim(ws.Cells(i, "D").Value)        If intervalStr <> "" Then            ' 确保每个唯一的区间只在字典中出现一次            If Not intervalDict.exists(intervalStr) Then                intervalDict.Add intervalStr, 0            End If        End If    Next i    ' 遍历B列数据，进行区间判断和计数    For i = 2 To lastRowB        If IsNumeric(ws.Cells(i, "B").Value) And ws.Cells(i, "B").Value <> "" Then            dataValue = ws.Cells(i, "B").Value            ' 遍历字典中的所有区间键，判断数据值属于哪个区间            For Each key In intervalDict.Keys                intervalStr = CStr(key)                ' 解析区间字符串，例如将 "0~39" 分解为下限和上限，分隔符波浪号"~"                Dim splitArr() As String                splitArr = Split(intervalStr, "~")                If UBound(splitArr) >= 1 Then                    lowerBound = Val(Trim(splitArr(0)))                    upperBound = Val(Trim(splitArr(1)))                    ' 判断数据是否在区间内（包含边界）                    If dataValue >= lowerBound And dataValue <= upperBound Then                        intervalDict(key) = intervalDict(key) + 1                        Exit For ' 找到一个匹配区间后立刻跳出内层循环                    End If                End If            Next key        End If    Next i    ' 将统计结果输出到E列    ' 先清空E列可能存在的旧结果（从第1行开始）    ws.Columns("E").ClearContents    outputRow = 1 ' 从E列的第1行开始输出    ' 写入表头    ws.Cells(outputRow, "E").Value = "数量"    outputRow = outputRow + 1    ' 遍历字典，将每个区间对应计数写入工作表    For Each key In intervalDict.Keys        ws.Cells(outputRow, "E").Value = intervalDict(key) ' 数量写入E列        outputRow = outputRow + 1    Next key    MsgBox "区间统计已完成！", vbInformation, "完成"    ' 清理对象    Set intervalDict = Nothing    Set ws = NothingEnd Sub