【Excel VBA编程】给代码“松绑”,从僵硬到灵动的设计进化

Sub CountDataByInterval()    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    '---------------------------------------    Dim rngData As Range, rngInterval As Range    Dim cell As Range    '----------------------------------------    ' 设置要操作的工作表，这里使用活动工作表    'Set ws = ActiveSheet    '-----------------------------------------------    ' 通过界面选择待统计的数据列    On Error Resume Next ' 防止用户取消选择    Set rngData = Application.InputBox( _        Prompt:="请选择包含待统计数据的列", _        Title:="选择数据列", _        Type:=8) ' Type:=8 表示选择单元格区域    On Error GoTo 0    If rngData Is Nothing Then        MsgBox "未选择数据区域，操作已取消。", vbExclamation        Exit Sub    End If    ' 通过界面选择区间定义的列 ---    On Error Resume Next    Set rngInterval = Application.InputBox( _        Prompt:="请选择包含区间定义的列", _        Title:="选择区间定义列", _        Type:=8)    On Error GoTo 0    If rngInterval Is Nothing Then        MsgBox "未选择区间定义区域，操作已取消。", vbExclamation        Exit Sub    End If    '----------------------------------------------------------    ' 创建字典对象用于存储每个区间及其对应的计数    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    For Each cell In rngInterval.Cells    '去掉表头        If cell.Row > rngInterval.Row Then            'intervalStr = Trim(ws.Cells(i, "D").Value)            intervalStr = Trim(cell.Value)            If intervalStr <> "" Then                ' 确保每个唯一的区间只在字典中出现一次                If Not intervalDict.exists(intervalStr) Then                    intervalDict.Add intervalStr, 0                End If            End If        End If    'Next i    Next cell    ' 遍历B列数据，进行区间判断和计数    'For i = 2 To lastRowB    For Each cell In rngData.Cells        'If IsNumeric(ws.Cells(i, "B").Value) And ws.Cells(i, "B").Value <> "" Then        If IsNumeric(cell.Value) And cell.Value <> "" Then            'dataValue = ws.Cells(i, "B").Value            dataValue = cell.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    Next cell    ' 将统计结果输出    ' 先清空可能存在的旧结果（从第1行开始）    'ws.Columns("E").ClearContents    rngInterval.Cells(1, 1).Offset(0, 1).ClearContents    outputRow = 1 ' 从E列的第1行开始输出    ' 写入表头    'ws.Cells(outputRow, "E").Value = "数量"    rngInterval.Cells(1, 1).Offset(0, 1).Value = "数量"    outputRow = outputRow + 1    ' 遍历字典，将每个区间对应计数写入工作表    For Each key In intervalDict.Keys        'ws.Cells(outputRow, "E").Value = intervalDict(key) ' 数量写入E列        rngInterval.Cells(outputRow, 1).Offset(0, 1) = intervalDict(key)        outputRow = outputRow + 1    Next key    MsgBox "区间统计已完成！", vbInformation, "完成"    ' 清理对象    Set intervalDict = Nothing    Set ws = NothingEnd Sub