楼主
kevinchengcw |
Q: 如何用vba代码实现数据区依指定单元格命令文本排序（含自定义排序）？
A: 代码如下：
- Private Sub Worksheet_Change(ByVal Target As Range) '利用工作表change事件进行处理
- If Not Intersect(Target, [n1]) Is Nothing Then '判断变化了的单元格范围是否包含指定单元格,本例为N1单元格
- Application.EnableEvents = False '关闭事件响应
- Dim Rng As Range
- Set Rng = Range("b2:l" & Cells(Rows.Count, 3).End(3).Row) '取得数据区范围,赋值给变量,便于后期引用
- Select Case [n1].Value '判断命令单元格的文本内容(注:文本内容以数据有效性方式存在及选择,防止输错)
- Case Is = "按班主任排列" '如果是"按班主任排列",该排序为自定义序列排序
- Dim Rules, Arr, Result, N&, I&, T&, C&, Dic As Object
- Rules = Split("周老师，梁老师，何老师，江老师", "，") '定义序列,并赋值给数组
- Set Dic = CreateObject("scripting.dictionary") '创建字典,用于装载已处理过的自定义序列字段,方便后期判断
- Arr = Rng.Value '将数据源赋值给数组
- ReDim Result(LBound(Arr) To UBound(Arr), LBound(Arr, 2) To UBound(Arr, 2)) '定义结果数组与源数组一致
- T = LBound(Arr) '取得数组行的最小下标值,即初始化结果数组行数值
- For N = LBound(Rules) To UBound(Rules) '循环自定义序列各项
- Dic.Add Rules(N), "" '添加当前循环到的项到字典中
- For I = LBound(Arr) To UBound(Arr) '循环数据源各行
- If Arr(I, 1) = Rules(N) Then '如果当前行第一列的值与自定义序列当前循环到的值一致,则
- For C = LBound(Arr, 2) To UBound(Arr, 2) '循环将当前行对应各列的值从源数据数组写入结果数据数组当前行
- Result(T, C) = Arr(I, C)
- Next C
- T = T + 1 '行值下移一行
- End If
- Next I
- Next N
- For I = LBound(Arr) To UBound(Arr) '二次循环数据源各行,用于找出有班主任名但未出现在自定义序列里的数据项,同样写入结果数组中
- If Not Dic.exists(Arr(I, 1)) And Trim(Arr(I, 1)) <> "" Then
- For C = LBound(Arr, 2) To UBound(Arr, 2)
- Result(T, C) = Arr(I, C)
- Next C
- T = T + 1
- End If
- Next I
- For I = LBound(Arr) To UBound(Arr) '第三次循环数据源各行,找出未写班主任名的数据项,写入结果数组(这样,未写班主任名的数据项就排到了数据的最后面)
- If Trim(Arr(I, 1)) = "" Then
- For C = LBound(Arr, 2) To UBound(Arr, 2)
- Result(T, C) = Arr(I, C)
- Next C
- T = T + 1
- End If
- Next I
- Rng = Result '将结果数组写入数据区
- Set Dic = Nothing '清空字典项目
- Case Is = "按姓氏排列" '如果是"按姓氏排列"则将数据源区利用excel自有功能根据姓名列进行排序
- Rng.Sort Rng.Cells(1, 2)
- Case Is = "语文成绩升序排列" '如果是"语文成绩升序排列"则将数据源区利用excel自有功能根据语文成绩列进行升序排序
- Rng.Sort Rng.Cells(1, 5), xlAscending
- Case Is = "总分降序排列" '如果是"总分降序排列"则将数据源区利用excel自有功能根据总分列进行降序排序
- Rng.Sort Rng.Cells(1, 11), xlDescending
- Case Else '其他可能出现的情况进行提醒
- MsgBox "排序依据无效"
- End Select
- Application.EnableEvents = True '打开事件响应
- End If
- End Sub
详见附件及素材源帖.
 EXCEL中单元格发生变化时，触发事件。。。.rar
|
