简单调整代码，实现汇总结果的四种效果

楼主 kevinchengcw	当我们获取了一个结果后，如何才能让结果以不同的方式显示出来，从而满足不同需求呢，请看下面例子：简单的调整代码，实现四种不同的汇总效果代码一： Sub Sums8_1() Dim Dic As Object Dim irow% Set Dic = CreateObject("Scripting.Dictionary") '建立字典，利用字典的key值唯一性得到人员清单 For irow = 2 To [D65536].End(3).Row If Not Dic.exists(Cells(irow, 4).Value) Then '如果不存在该人名，则 Dic(Cells(irow, 4).Value) = Cells(irow, 6) '向字典中添加该人名 Else '否则（即已存在当前人名时） Dic(Cells(irow, 4).Value) = Cells(irow, 6) + Dic(Cells(irow, 4).Value) 'item值等于item值加上对应的销售量 End If Next For irow = [D65536].End(3).Row To 2 Step -1 '从后向前插入汇总值可以避免行数计数出错 If Dic.exists(Cells(irow, 4).Value) Then '因为是要将汇总值加在个人单项值的后面，所以判断当前单元格对应人名在字典中是否存在，如果存在则 Rows(irow + 1).Insert 3 '在其下一行插入一空行，并写入下述内容及格式 Cells(irow + 1, 4) = Cells(irow, 4) & "小计" Cells(irow + 1, 7) = Dic(Cells(irow, 4).Value) Range(Cells(irow + 1, 4), Cells(irow + 1, 7)).Interior.Color = vbRed Dic.Remove (Cells(irow, 4).Value) '完成后删除该人名，这样不会重复插入 End If Next Dic.RemoveAll ‘清空字典 End Sub 代码二： Sub Sums8_2() Dim Dic As Object Dim irow% Set Dic = CreateObject("Scripting.Dictionary") For irow = 2 To [D65536].End(3).Row If Not Dic.exists(Cells(irow, 4).Value) Then Dic(Cells(irow, 4).Value) = Cells(irow, 6) Else Dic(Cells(irow, 4).Value) = Cells(irow, 6) + Dic(Cells(irow, 4).Value) End If Next i = [D65536].End(3).Row + 1 ‘放在结尾处则最开始行是现有最后一行的下一行 For irow = 2 To [D65536].End(3).Row If Dic.exists(Cells(irow, 4).Value) Then ‘依序调出各个人的名字 Cells(i, 4) = Cells(irow, 4).Value & "小计" Cells(i, 7) = Dic(Cells(irow, 4).Value) ‘写入相应值 Range(Cells(i, 4), Cells(i, 7)).Interior.Color = vbRed i = i + 1 Dic.Remove (Cells(irow, 4).Value) ‘删除该名字的项，这样就不会重复写入 End If Next Dic.RemoveAll End Sub 代码三： Sub Sums8_3() Dim Dic As Object Dim irow% Set Dic = CreateObject("Scripting.Dictionary") For irow = 2 To [D65536].End(3).Row If Not Dic.exists(Cells(irow, 4).Value) Then Dic(Cells(irow, 4).Value) = Cells(irow, 6) Else Dic(Cells(irow, 4).Value) = Cells(irow, 6) + Dic(Cells(irow, 4).Value) End If Next For irow = [D65536].End(3).Row To 2 Step -1 ‘类似代码一，要插入行来完成，所以要从后向前可以避免计数出错 If Dic.exists(Cells(irow, 4).Value) And Cells(irow - 1, 4).Value <> Cells(irow, 4).Value Then ‘因为是在两个名字交界处，所以判断当前行与其上一行是否一致，不一致则证明是两个名字交界处，在当前行插入并写入数据 Rows(irow).Insert 3 Cells(irow, 4) = Cells(irow + 1, 4) & "小计" Cells(irow, 7) = Dic(Cells(irow + 1, 4).Value) Range(Cells(irow, 4), Cells(irow, 7)).Interior.Color = vbRed Dic.Remove (Cells(irow + 1, 4).Value) ‘移除字典中该名字的内容，防止重复 End If Next Dic.RemoveAll End Sub 代码四： Sub Sums8_4() Dim Dic As Object Dim irow% Set Dic = CreateObject("Scripting.Dictionary") For irow = 2 To [D65536].End(3).Row If Not Dic.exists(Cells(irow, 4).Value) Then Dic(Cells(irow, 4).Value) = Cells(irow, 6) Else Dic(Cells(irow, 4).Value) = Cells(irow, 6) + Dic(Cells(irow, 4).Value) End If Next Rows("2:" & Dic.Count + 1).Insert 3 ‘因为是将结果全部插入到前面，先要知道需要多少行，利用dic.count即可获得所需行数，因为是从第二行开始插入，则所对应行的范围是第2行到dicount+2-1(即dic.count+1)，先插入空白行 i = 2 ‘ 设定开始写入汇总的行数值 For irow = Dic.Count + 1 To [D65536].End(3).Row ‘因插入空白行，现有数据下移了dic.count行，所以原数据区域的取值范围起始值变成了2+dic.count-1(即dic.count+1)到最末行 If Dic.exists(Cells(irow, 4).Value) And Cells(irow, 4) <> Cells(irow - 1, 4) Then ‘如果当前行与上一行不一致，则说明到了交界处，判断字典中是否存在该对应值并写入到汇总数据当前行 Cells(i, 4) = Cells(irow, 4).Value & "小计" Cells(i, 7) = Dic(Cells(irow, 4).Value) Range(Cells(i, 4), Cells(i, 7)).Interior.Color = vbRed i = i + 1 ‘汇总数据写入行要相应增加 Dic.Remove (Cells(irow, 4).Value) ‘删除已写入值 End If Next Dic.RemoveAll End Sub
2楼 yzcyzc1023	thank you。
3楼 aob	看看高手的表演，学习了！
4楼 E林好汉	举一反三，赞一个！