作者：绿色风
分类：
时间：2022-08-18
浏览：81
楼主
kevinchengcw |
利用字典key的唯一性及item项的“包容性”，对于汇总一个成绩单中的个人分科项目及分数等信息就轻而易举了，下面以一个例子来说明，代码如下：- Sub test()
- Dim Dic, Arr, Arr2
- Dim M, N As Integer
- Application.ScreenUpdating = False '关闭屏幕刷新，提高处理速度
- Set Dic = CreateObject("scripting.dictionary") '创建字典
- With Worksheets("sheet1")
- For M = 2 To .Cells(.Columns(1).Cells.Count, 1).End(3).Row '循环统计sheet1工作表中第二行开始的数据
- If Dic.Count = 0 Then '如果字典计数不为0（主要是为了跳过第一个数据，因为如果字典还没有数据存入，直接判断是否存在某一数据会出错）
- Dic.Add .Cells(M, 1).Value, .Cells(M, 2).Value & vbTab & .Cells(M, 3).Value '如果字典是空则添加字典项，以姓名为key，后面的科目及分项成绩以特定字符分隔后存入item项中
- Else '如果字典不为空
- If Dic.exists(.Cells(M, 1).Value) Then '如果当前姓名已存在于字典中，则将对应的item项追加以特定字符分隔的科目项及成绩项
- Dic(.Cells(M, 1).Value) = Dic(.Cells(M, 1).Value) & vbTab & .Cells(M, 2).Value & vbTab & .Cells(M, 3).Value
- Else '未存在该姓名则添加新字典项
- Dic.Add .Cells(M, 1).Value, .Cells(M, 2).Value & vbTab & .Cells(M, 3).Value
- End If
- End If
- Next M
- End With
- With Worksheets("sheet2") '向sheet2写入数据
- .Activate '为方便完成后显示结果，激活sheet2
- Arr = Dic.keys '将字典的keys赋值给数组，便于取用
- For N = LBound(Arr) To UBound(Arr) '循环取出数组各项及对应的字典item项
- .Cells(N + 1, 1) = Arr(N) '第一列单元格写出姓名（即字典的key），数组下标未明确标示则以0开始，则第一行需表示为n+1
- Arr2 = Split(Dic(Arr(N)), vbTab) '将对应的item项取出并依特定字符分割放入数组2里
- For M = LBound(Arr2) To UBound(Arr2) '循环取出item中的分项内容，写入对应列里
- .Cells(N + 1, M + 2) = Arr2(M)
- Next M
- Erase Arr2 '为避免出错，完成后清空数组2
- Next N
- End With
- Set Dic = Nothing '清空项目
- Application.ScreenUpdating = True '打开屏幕刷新
- MsgBox "处理完成" '显示提示信息
- End Sub
详情参阅附件
 改变数据的显示样式.rar
|
2楼
rongjun |
学习K版代码
 |
3楼
kangguowei |
太高级了. |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一