一.适用场景1、频次统计多个产品每销售一次产出一条销售数据需要统计每个产品的销售量类比countif函数优势是可以在没有名单的情况下直接完成统计2、频次排序根据产品销售数量升序降序销售最多的产品放上面/下面销售最少的放上面/下面;类比先用countif函数求出频率然后升序降序二.效果演示-频次统计1.打开要统计频次的工作表xlsm工作表不要关闭启用宏2.按ALTF8运行频次统计3.选择要统计的列点击确定4.输入标题行数标题行不参与统计点击确定5.选择空白单元格点击确定输出数据6.输出完成点击确定得到结果三.效果演示-频次排序1.打开要进行频次排序的工作表xlsm工作表不要关闭启用宏2.按ALTF8运行指定列频率排序3.选择排序参考列点击确定4.输入标题行的行数点击确定5.选择降序还是升序这里选择降序点击确定6.排序完成频次从高到低7.随后可点击是进一步完成频次统计也可选择否结束任务三.代码载入步骤1.新建一个xlsx工作表另存为xlsm文件改名为频次统计及升序降序2.打开它注意启用宏3.按altf11调出代码框右键点击project-插入-模块4.插入以下代码指定频率排序Sub 指定列频率排序() Dim inputRange As String Dim headerRows As String Dim selectedColumns As Variant Dim headerRowArray As Variant Dim lastRow As Long Dim outputCol As Long Dim col As Long Dim startRow As Long Dim i As Long Dim rng As Range Dim firstNonEmptyRow As Long 弹框输入 - 选择列 On Error Resume Next Set rng Application.InputBox(请选择排序参考列点击该列的任意单元格, 选择列, Type:8) On Error GoTo 0 If rng Is Nothing Then Exit Sub 直接获取列号并转为字母 inputRange Split(Cells(1, rng.Column).Address, $)(1) 修改提示文字更清楚地说明功能 headerRows InputBox(请输入标题行数 vbCrLf _ 从第一个非空单元格开始向下数N行作为标题行不参与排序 vbCrLf _ 例如输入 2 表示前2行是标题, _ 输入标题行数, 1) If headerRows Then Exit Sub 验证输入是否为数字 If Not IsNumeric(headerRows) Then MsgBox 请输入有效的数字, vbCritical Exit Sub End If 如果输入的是小数取整 If InStr(headerRows, .) 0 Then headerRows CStr(Int(CDbl(headerRows))) MsgBox 标题行数已取整为 headerRows, vbInformation End If selectedColumns Split(inputRange, ,) headerRowArray Split(headerRows, ,) 新增选择排序方式 Dim sortOrder As String sortOrder InputBox(请选择排序方式 vbCrLf _ 输入 1 或 降序频率从高到低 vbCrLf _ 输入 2 或 升序频率从低到高, _ 排序方式, 1) 如果用户点击取消退出程序 If StrPtr(sortOrder) 0 Then Exit Sub End If 如果输入空值默认使用降序 If sortOrder Then sortOrder 1 获取列号 col Range(Trim(selectedColumns(0)) 1).Column 核心修改找到第一个非空单元格 firstNonEmptyRow FindFirstNonEmptyRow(col) If firstNonEmptyRow -1 Then MsgBox 所选列中没有任何数据, vbCritical Exit Sub End If 计算数据起始行第一个非空行 标题行数 Dim headerCount As Long headerCount CLng(Trim(headerRowArray(0))) startRow firstNonEmptyRow headerCount 验证起始行是否超出范围 If startRow ActiveSheet.Rows.Count Then MsgBox 标题行数过多超出了工作表范围, vbCritical Exit Sub End If 获取该列最后一行从底部向上找第一个非空单元格 lastRow ActiveSheet.Cells(ActiveSheet.Rows.Count, col).End(xlUp).Row 验证数据是否存在 If lastRow startRow Then MsgBox 选择的列中数据不足无法进行排序 vbCrLf _ 第一个非空行 firstNonEmptyRow vbCrLf _ 标题行数 headerCount vbCrLf _ 数据起始行 startRow vbCrLf _ 最后一行 lastRow, vbCritical Exit Sub End If 先确定排序范围在添加辅助列之前 Dim sortRange As Range Dim leftCol As Long Dim rightCol As Long 1. 向左扩展找到选定列左侧连续有数据的列 leftCol col Do While leftCol 1 检查左边一列在当前数据行范围内是否有数据 If Application.WorksheetFunction.CountA(ActiveSheet.Range(ActiveSheet.Cells(startRow, leftCol - 1), ActiveSheet.Cells(lastRow, leftCol - 1))) 0 Then leftCol leftCol - 1 Else Exit Do End If Loop 2. 向右扩展找到选定列右侧连续有数据的列遇到空列停止 rightCol col Do While rightCol ActiveSheet.Columns.Count 检查右边一列在当前数据行范围内是否有数据 If Application.WorksheetFunction.CountA(ActiveSheet.Range(ActiveSheet.Cells(startRow, rightCol 1), ActiveSheet.Cells(lastRow, rightCol 1))) 0 Then rightCol rightCol 1 Else Exit Do End If Loop 获取输出列位置在数据右侧第一列但要在rightCol之后 outputCol rightCol 1 如果输出列超出范围提示错误 If outputCol ActiveSheet.Columns.Count Then MsgBox 没有足够的列用于输出辅助数据, vbCritical Exit Sub End If 在outputCol位置插入一列空白列避免覆盖原有数据 ActiveSheet.Columns(outputCol).Insert Shift:xlToRight 添加辅助列标题在第一个非空行 ActiveSheet.Cells(firstNonEmptyRow, outputCol).Value 频率辅助列 核心替换点使用数组一次性读取和写入最快 Dim dataArray As Variant Dim freqDict As Object Set freqDict CreateObject(Scripting.Dictionary) 一次性读取数据到数组 dataArray ActiveSheet.Range(ActiveSheet.Cells(startRow, col), ActiveSheet.Cells(lastRow, col)).Value 统计频率到字典 For i 1 To UBound(dataArray, 1) If Not IsEmpty(dataArray(i, 1)) Then Dim key As String key CStr(dataArray(i, 1)) If freqDict.Exists(key) Then freqDict(key) freqDict(key) 1 Else freqDict.Add key, 1 End If End If Next i 一次性写入频率值 Dim freqArray() As Variant ReDim freqArray(1 To UBound(dataArray, 1), 1 To 1) For i 1 To UBound(dataArray, 1) If Not IsEmpty(dataArray(i, 1)) Then freqArray(i, 1) freqDict(CStr(dataArray(i, 1))) Else freqArray(i, 1) 0 End If Next i 一次性写入到工作表 ActiveSheet.Range(ActiveSheet.Cells(startRow, outputCol), ActiveSheet.Cells(lastRow, outputCol)).Value freqArray 将标题行的辅助列值设为0从第一个非空行开始共headerCount行 For i 0 To headerCount - 1 ActiveSheet.Cells(firstNonEmptyRow i, outputCol).Value 0 Next i 构建排序范围 Set sortRange ActiveSheet.Range(ActiveSheet.Cells(startRow, leftCol), ActiveSheet.Cells(lastRow, outputCol)) 记录排序范围信息用于提示 Dim sortStartRow As Long Dim sortEndRow As Long Dim sortStartCol As Long Dim sortEndCol As Long sortStartRow sortRange.Row sortEndRow sortRange.Row sortRange.Rows.Count - 1 sortStartCol sortRange.Column sortEndCol sortRange.Column sortRange.Columns.Count - 1 修改后的排序代码可选择升降序 With ActiveSheet.Sort .SortFields.Clear 根据用户选择决定频率排序方式 Dim freqOrder As XlSortOrder If sortOrder 1 Or LCase(sortOrder) 降序 Or LCase(sortOrder) desc Then freqOrder xlDescending 降序频率从高到低 Else freqOrder xlAscending 升序频率从低到高 End If 第一个排序条件频率按用户选择排序 使用相对列号在排序范围内的位置 .SortFields.Add key:sortRange.Columns(outputCol - sortRange.Column 1), Order:freqOrder 第二个排序条件对象名称升序使用原始数据列 .SortFields.Add key:sortRange.Columns(col - leftCol 1), Order:xlAscending .SetRange sortRange .Header xlNo .Apply End With 删除辅助列 Application.DisplayAlerts False ActiveSheet.Columns(outputCol).Delete Application.DisplayAlerts True 只显示排序范围提示只显示原始数据列不包含辅助列 Dim sortRangeInfo As String Dim colLetterStart As String Dim colLetterEnd As String 获取列字母只显示原始数据范围不包含辅助列 colLetterStart Split(ActiveSheet.Cells(1, leftCol).Address, $)(1) colLetterEnd Split(ActiveSheet.Cells(1, rightCol).Address, $)(1) 构建排序范围提示信息不包含数据统计 sortRangeInfo 排序完成 vbCrLf vbCrLf _ 【排序范围】 vbCrLf _ 行范围第 startRow 行 到 第 lastRow 行 vbCrLf _ 列范围 colLetterStart 列 到 colLetterEnd 列 vbCrLf _ 完整区域 colLetterStart startRow : colLetterEnd lastRow vbCrLf vbCrLf _ 排序方式 IIf(freqOrder xlDescending, 降序频率从高到低, 升序频率从低到高) vbCrLf _ 统计列 Split(ActiveSheet.Cells(1, col).Address, $)(1) 列 显示排序范围 MsgBox sortRangeInfo, vbInformation, 排序完成 询问是否进行频次统计 Dim response As VbMsgBoxResult response MsgBox(是否需要进行频次统计 vbCrLf _ 将统计选定列中各值的出现次数, vbYesNo vbQuestion, 频次统计) If response vbYes Then 调用频次统计传入已选定的参数 频次统计_自动 col, headerRowArray, firstNonEmptyRow, startRow, lastRow End If End Sub 新增函数找到指定列的第一个非空单元格 Function FindFirstNonEmptyRow(col As Long) As Long Dim i As Long 从第1行开始向下查找第一个非空单元格 For i 1 To ActiveSheet.Rows.Count If Not IsEmpty(ActiveSheet.Cells(i, col)) Then FindFirstNonEmptyRow i Exit Function End If Next i 如果整列都是空的返回-1 FindFirstNonEmptyRow -1 End Function 修改后的函数获取第一个数据行表头行之后的行 Function GetFirstDataRow(headerRowArray As Variant, col As Long) As Long 功能从指定列中找到第一个非空单元格然后加上表头行数 headerRowArray: 表头行数数组用户输入 col: 选择的列号 Dim firstNonEmptyRow As Long Dim i As Long Dim totalHeaderRows As Long 计算表头总行数 totalHeaderRows 0 For i 0 To UBound(headerRowArray) totalHeaderRows totalHeaderRows CLng(Trim(headerRowArray(i))) Next i 找到该列的第一个非空单元格 firstNonEmptyRow 1 Do While IsEmpty(ActiveSheet.Cells(firstNonEmptyRow, col)) And firstNonEmptyRow ActiveSheet.Rows.Count firstNonEmptyRow firstNonEmptyRow 1 Loop 如果整个列都是空的返回错误 If firstNonEmptyRow ActiveSheet.Rows.Count Then GetFirstDataRow -1 返回-1表示错误 Exit Function End If 数据行 第一个非空行 表头行数 GetFirstDataRow firstNonEmptyRow totalHeaderRows 如果超出范围返回-1 If GetFirstDataRow ActiveSheet.Rows.Count Then GetFirstDataRow -1 End If End Function 检查是否为表头行可选但包含以备不时之需 Function IsHeaderRow(rowNum As Long, firstNonEmptyRow As Long, headerCount As Long) As Boolean 判断某行是否在标题行范围内 If rowNum firstNonEmptyRow And rowNum firstNonEmptyRow headerCount Then IsHeaderRow True Else IsHeaderRow False End If End Function 修改后的频次统计适配新逻辑 Sub 频次统计_自动(col As Long, headerRowArray As Variant, firstNonEmptyRow As Long, startRow As Long, lastRow As Long) Dim dataRng As Range, outputCell As Range Dim cell As Range Dim dict As Object Dim key As Variant Dim i As Long Dim j As Long Dim headerCount As Long Dim headerValue As String 计算标题行数 headerCount CLng(Trim(headerRowArray(0))) 1. 构建数据区域使用传入的参数 Set dataRng ActiveSheet.Range(ActiveSheet.Cells(startRow, col), ActiveSheet.Cells(lastRow, col)) 2. 获取表头第一个非空行的值 headerValue ActiveSheet.Cells(firstNonEmptyRow, col).Value If IsEmpty(headerValue) Or headerValue Then headerValue 数据 如果表头为空使用默认名称 End If 3. 统计频次 Set dict CreateObject(Scripting.Dictionary) dict.CompareMode vbTextCompare For Each cell In dataRng If Not IsEmpty(cell) Then Dim v As String v Trim(CStr(cell.Value)) If v Then If dict.Exists(v) Then dict(v) dict(v) 1 Else dict.Add v, 1 End If End If End If Next cell If dict.Count 0 Then MsgBox 所选列中无有效数据全为空或空白, vbCritical Exit Sub End If 4. 选择输出位置仍然需要用户选择位置 Set outputCell Application.InputBox(请选择频次统计的输出起始单元格, 输出位置, Type:8) If outputCell Is Nothing Then Exit Sub 5. 转为数组并排序降序 Dim arr() As Variant ReDim arr(1 To dict.Count, 1 To 2) i 1 For Each key In dict.Keys arr(i, 1) key arr(i, 2) dict(key) i i 1 Next key 简单冒泡排序按第2列降序 Dim temp1 As Variant, temp2 As Variant For i 1 To dict.Count - 1 For j i 1 To dict.Count If arr(i, 2) arr(j, 2) Then temp1 arr(i, 1): temp2 arr(i, 2) arr(i, 1) arr(j, 1): arr(i, 2) arr(j, 2) arr(j, 1) temp1: arr(j, 2) temp2 End If Next j Next i 6. 输出表头使用原标题 headerValue ActiveSheet.Cells(startRow - 1, col).Value outputCell.Value headerValue outputCell.Offset(0, 1).Value 数量 7. 输出数据 outputCell.Offset(1, 0).Resize(dict.Count, 2).Value arr 8. 格式化 Dim tblRng As Range Set tblRng outputCell.Resize(dict.Count 1, 2) With tblRng .Font.Name 微软雅黑 .Font.Size 10 .HorizontalAlignment xlCenter .VerticalAlignment xlCenter End With 表头格式 With outputCell.Resize(1, 2) .Interior.Color RGB(238, 130, 47) .Font.Bold True .Font.Color RGB(255, 255, 255) End With 外框线 With tblRng.Borders .LineStyle xlNone End With tblRng.Borders(xlEdgeLeft).LineStyle xlContinuous tblRng.Borders(xlEdgeTop).LineStyle xlContinuous tblRng.Borders(xlEdgeBottom).LineStyle xlContinuous tblRng.Borders(xlEdgeRight).LineStyle xlContinuous 频次统计完成后显示统计结果 MsgBox 频次统计完成 vbCrLf vbCrLf _ 【统计结果】 vbCrLf _ 统计列 Split(ActiveSheet.Cells(1, col).Address, $)(1) 列 vbCrLf _ 统计项数 dict.Count 项 vbCrLf _ 数据范围第 startRow 行 到 第 lastRow 行 vbCrLf _ 输出位置 outputCell.Address, vbInformation, 频次统计完成 End Sub5.再次创建个新模块插入代码频次统计Sub 频次统计() Dim col As Long Dim startRow As Long Dim lastRow As Long Dim dataRng As Range Dim outputCell As Range Dim cell As Range Dim dict As Object Dim key As Variant Dim i As Long Dim j As Long Dim headerRows As String Dim headerCount As Long Dim firstNonEmptyRow As Long Dim rng As Range Dim v As String Dim headerValue As String Dim arr() As Variant Dim temp1 As Variant Dim temp2 As Variant Dim tblRng As Range 弹框选择要统计的列 On Error Resume Next Set rng Application.InputBox(请选择要统计的列点击该列的任意单元格, 选择列, Type:8) On Error GoTo 0 If rng Is Nothing Then Exit Sub 获取列号 col rng.Column 输入标题行数 headerRows InputBox(请输入标题行数 vbCrLf _ 从第一个非空单元格开始向下数N行作为标题行不参与统计 vbCrLf _ 例如输入 2 表示前2行是标题, _ 输入标题行数, 1) If headerRows Then Exit Sub 验证输入是否为数字 If Not IsNumeric(headerRows) Then MsgBox 请输入有效的数字, vbCritical Exit Sub End If 如果输入的是小数取整 If InStr(headerRows, .) 0 Then headerRows CStr(Int(CDbl(headerRows))) MsgBox 标题行数已取整为 headerRows, vbInformation End If headerCount CLng(Trim(headerRows)) 找到第一个非空单元格 firstNonEmptyRow FindFirstNonEmptyRow(col) If firstNonEmptyRow -1 Then MsgBox 所选列中没有任何数据, vbCritical Exit Sub End If 计算数据起始行第一个非空行 标题行数 startRow firstNonEmptyRow headerCount 验证起始行是否超出范围 If startRow ActiveSheet.Rows.Count Then MsgBox 标题行数过多超出了工作表范围, vbCritical Exit Sub End If 获取该列最后一行 lastRow ActiveSheet.Cells(ActiveSheet.Rows.Count, col).End(xlUp).Row 验证数据是否存在 If lastRow startRow Then MsgBox 选择的列中数据不足无法进行统计 vbCrLf _ 第一个非空行 firstNonEmptyRow vbCrLf _ 标题行数 headerCount vbCrLf _ 数据起始行 startRow vbCrLf _ 最后一行 lastRow, vbCritical Exit Sub End If 构建数据区域 Set dataRng ActiveSheet.Range(ActiveSheet.Cells(startRow, col), ActiveSheet.Cells(lastRow, col)) 统计频次 Set dict CreateObject(Scripting.Dictionary) dict.CompareMode vbTextCompare For Each cell In dataRng If Not IsEmpty(cell) Then v Trim(CStr(cell.Value)) If v Then If dict.Exists(v) Then dict(v) dict(v) 1 Else dict.Add v, 1 End If End If End If Next cell If dict.Count 0 Then MsgBox 所选列中无有效数据全为空或空白, vbCritical Exit Sub End If 选择输出位置 Set outputCell Application.InputBox(请选择频次统计的输出起始单元格, 输出位置, Type:8) If outputCell Is Nothing Then Exit Sub 转为数组并排序按频次降序 ReDim arr(1 To dict.Count, 1 To 2) i 1 For Each key In dict.Keys arr(i, 1) key arr(i, 2) dict(key) i i 1 Next key 冒泡排序按第2列降序 For i 1 To dict.Count - 1 For j i 1 To dict.Count If arr(i, 2) arr(j, 2) Then temp1 arr(i, 1) temp2 arr(i, 2) arr(i, 1) arr(j, 1) arr(i, 2) arr(j, 2) arr(j, 1) temp1 arr(j, 2) temp2 End If Next j Next i 获取表头 headerValue ActiveSheet.Cells(firstNonEmptyRow, col).Value If IsEmpty(headerValue) Or headerValue Then headerValue 数据 End If 输出表头 outputCell.Value headerValue outputCell.Offset(0, 1).Value 数量 输出数据 outputCell.Offset(1, 0).Resize(dict.Count, 2).Value arr 格式化表格 Set tblRng outputCell.Resize(dict.Count 1, 2) With tblRng .Font.Name 微软雅黑 .Font.Size 10 .HorizontalAlignment xlCenter .VerticalAlignment xlCenter End With 表头格式 With outputCell.Resize(1, 2) .Interior.Color RGB(238, 130, 47) .Font.Bold True .Font.Color RGB(255, 255, 255) End With 边框 With tblRng.Borders .LineStyle xlNone End With tblRng.Borders(xlEdgeLeft).LineStyle xlContinuous tblRng.Borders(xlEdgeTop).LineStyle xlContinuous tblRng.Borders(xlEdgeBottom).LineStyle xlContinuous tblRng.Borders(xlEdgeRight).LineStyle xlContinuous 显示统计结果 MsgBox 频次统计完成 vbCrLf vbCrLf _ 【统计结果】 vbCrLf _ 统计列 Split(ActiveSheet.Cells(1, col).Address, $)(1) 列 vbCrLf _ 统计项数 dict.Count 项 vbCrLf _ 数据范围第 startRow 行 到 第 lastRow 行 vbCrLf _ 输出位置 outputCell.Address, vbInformation, 频次统计完成 End Sub Function FindFirstNonEmptyRow(col As Long) As Long Dim i As Long For i 1 To ActiveSheet.Rows.Count If Not IsEmpty(ActiveSheet.Cells(i, col)) Then FindFirstNonEmptyRow i Exit Function End If Next i FindFirstNonEmptyRow -1 End Function6.保存返回工作表可以使用了