当前位置：首页 > news >正文

Excel使用VBA批量计算指定列的中位数和标准差并筛选指定列数据

news 来源：原创 2025/5/13 11:20:16

兜兜转转，还是回到了原点，好久不写博客了。
周末调试了三四个小时，终于差不多了，不过还有一小部分问题，后面有时间再弄吧

使用方法

使用Excel 2007以上的版本，打开想要处理的XLSX表格，按Alt + F11按键打开宏编译器，粘贴想要的代码块，之后按下F5键运行即可。如果按下Alt + F11没有代码界面，可以在菜单栏打开代码窗口即可
在这里插入图片描述

初始Excel测试数据格式可参照如下:

在这里插入图片描述

代码如下:

功能1:将一组12列数据，取前10列为有效数据，第11列计算为中位数，第12列计算为标准差，并给出基本的提示信息了。

Sub UpdateColumns()On Error GoTo ErrorHandlerApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualDim lastRow As Long, lastCol As IntegerDim i As Long, j As Integer, groupCols As IntegerDim rng As RangeDim processedGroups As Integer  ' 新增处理组计数器groupCols = 12processedGroups = 0lastRow = Cells(Rows.Count, 1).End(xlUp).RowlastCol = Cells(1, Columns.Count).End(xlToLeft).ColumnFor j = 2 To lastCol Step groupColsprocessedGroups = processedGroups + 1  ' 计数每组处理' 动态列边界检查（防止溢出）If j + 11 > Columns.Count Then Exit For' 设置列标题With Cells(1, j + 10).Value = "中位数".HorizontalAlignment = xlCenterEnd WithWith Cells(1, j + 11).Value = "标准差".HorizontalAlignment = xlCenterEnd WithFor i = 2 To lastRow' 动态计算可用列数Dim validCols As IntegervalidCols = Application.Min(9, lastCol - j)Set rng = Range(Cells(i, j), Cells(i, j + validCols))' 计算中位数With Cells(i, j + 10)If .Value = "" Then.Value = Application.Median(rng)End IfEnd With' 计算标准差With Cells(i, j + 11)If .Value = "" ThenIf Application.Count(rng) > 1 Then.Value = Application.StDev_S(rng).NumberFormat = "0.00"Else.Value = "N/A"End IfEnd IfEnd WithNext iNext jColumns.AutoFit' 成功提示（新增部分）MsgBox "数据更新完成！" & vbCrLf & _"成功处理 " & processedGroups & " 个数据组" & vbCrLf & _"最后行号：" & lastRow & "  总列数：" & lastCol, _vbInformation + vbOKOnly, _"操作报告"Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomaticExit SubErrorHandler:MsgBox "操作在以下位置中断：" & vbCrLf & _"数据组：" & processedGroups + 1 & "  当前行：" & i & vbCrLf & _"错误描述：" & Err.Description, _vbCritical, _"错误报告"Application.ScreenUpdating = TrueApplication.Calculation = xlCalculationAutomatic
End Sub

功能2:按列筛选出想要展示的Excel数据。
用法:修改这一行代码的赋值为想要展示的列名即可:
Const HEADERS_TO_KEEP As String = “Item,Value1,Value3”

Option Explicit'============= 主过程 =============
Sub FilterColumnsWithMedianAndStdDev()' 配置区域（用户只需修改此处）------------------Const TARGET_SHEET As String = "Sheet1"           ' 目标工作表名Const HEADERS_TO_KEEP As String = "Item,Value1,Value3"   ' 要保留的列标题（逗号分隔）' ----------------------------------------------Dim ws As WorksheetDim headerNames() As StringDim colDict As ObjectDim cell As RangeDim currentCol As Long, lastCol As LongDim colName As Variant, normalizedName As StringDim groupStartCol As Long, groupEndCol As LongDim groupIndex As LongOn Error GoTo ErrorHandlerSet colDict = CreateObject("Scripting.Dictionary")' 1. 获取目标工作表Set ws = ThisWorkbook.Sheets(TARGET_SHEET)' 2. 解析用户输入的列名并转为数组headerNames = Split(HEADERS_TO_KEEP, ",")If UBound(headerNames) < 0 ThenMsgBox "未指定要保留的列名！", vbExclamationExit SubEnd If' 3. 遍历标题行，构建列名字典（Key=标准化列名，Value=列号）lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).ColumnFor Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol))normalizedName = Trim(UCase(cell.value))If Not colDict.Exists(normalizedName) ThencolDict.Add normalizedName, cell.ColumnEnd IfNext cell' 4. 校验用户输入的列名是否存在For Each colName In headerNamesnormalizedName = Trim(UCase(colName))If Not colDict.Exists(normalizedName) ThenMsgBox "错误：列名 [" & colName & "] 不存在！", vbCriticalExit SubEnd IfNext colName' 5. 初始化组索引和开始列groupIndex = 0groupStartCol = 1' 6. 主逻辑：遍历所有列，处理每组前10列及其对应中位数、标准差列For currentCol = 1 To lastColnormalizedName = Trim(UCase(ws.Cells(1, currentCol).value))' 检查是否为中位数或标准差列（每组最后两列）If InStr(normalizedName, "中位数") > 0 Or InStr(normalizedName, "标准差") > 0 ThengroupEndCol = currentCol - 1  ' 当前组的结束列是当前列的前一列' 检查组内是否有需要保留的列If AnyColumnToKeepInGroup(ws, groupStartCol, groupEndCol, headerNames) Then' 保留当前组的第11、12列（即当前列和下一列）ws.Columns(currentCol).Hidden = Falsews.Columns(currentCol + 1).Hidden = FalseElse' 隐藏当前组的第11、12列ws.Columns(currentCol).Hidden = Truews.Columns(currentCol + 1).Hidden = TrueEnd If' 更新组索引和起始列groupIndex = groupIndex + 1currentCol = currentCol + 1  ' 跳过已经处理的标准差列groupStartCol = currentCol + 1  ' 下一组开始列Else' 处理普通列：隐藏非指定列If Not IsInArray(normalizedName, headerNames) Thenws.Columns(currentCol).Hidden = TrueEnd IfEnd IfNext currentColMsgBox "操作完成！已根据条件隐藏非指定列。", vbInformationExit SubErrorHandler:MsgBox "运行时错误 " & Err.Number & "：" & Err.Description & vbCrLf & _"可能原因：" & vbCrLf & _"- 工作表 '" & TARGET_SHEET & "' 不存在" & vbCrLf & _"- 工作表为空或标题行格式异常", vbCritical
End Sub'============= 辅助函数 =============
' 检查数组中是否包含某个值（标准化比较）
Function IsInArray(val As String, arr As Variant) As BooleanDim element As VariantFor Each element In arrIf Trim(UCase(element)) = val ThenIsInArray = TrueExit FunctionEnd IfNextIsInArray = False
End Function' 检查组内是否有要保留的列（核心逻辑）
Function AnyColumnToKeepInGroup( _ByVal ws As Worksheet, _ByVal startCol As Long, _ByVal endCol As Long, _ByRef headerNames() As String _
) As BooleanDim i As LongDim normalizedName As String' 遍历组内每列标题For i = startCol To endColnormalizedName = Trim(UCase(ws.Cells(1, i).value))If IsInArray(normalizedName, headerNames) ThenAnyColumnToKeepInGroup = TrueExit FunctionEnd IfNext iAnyColumnToKeepInGroup = False
End Function

功能3：将Excel中隐藏的所有列展开

' 扩展功能：一键显示所有隐藏列
Sub UnhideAllColumns()On Error Resume NextThisWorkbook.Sheets("Sheet1").Columns.Hidden = FalseMsgBox "已显示所有隐藏列！", vbInformation
End Sub