明了的数量汇总显示

向東

工作中做的一个功能，可以汇总显示相同产品对应数量，只是代码写的不好，分享一下给大家，看看有没有更好的写法。


代码如下：

1. Private Sub CommandButton2_Click() ' 汇总
   
2.     Dim r, i, j, h, M As Long
   
3.     Dim Rng As Variant
   
4.    
   
5. 
   
6.     r = Worksheets("汇总表").Range("C65536").End(xlUp).Row
   
7.     Rng = Worksheets("汇总表").Range("A1:I" & r).Value
   
8.    
   
9. '------------------------------------------------------------------------按 仓位、货品编码 排序
   
10.    Application.ScreenUpdating = True
    
11. 
    
12.     Range("A2:I" & r).Sort Key1:=Range("D2"), Order1:=xlAscending, Key2:=Range("E2") _
    
13.         , Order2:=xlAscending, Key3:=Range("G2"), Order3:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=True _
    
14.         , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
    
15.         xlSortNormal, DataOption2:=xlSortNormal
    
16. 
    
17. '------------------------------------------------------------------------按 货品名 对 大于1的数量求和
    
18.     r = Worksheets("汇总表").Range("C65536").End(xlUp).Row
    
19.     Rng = Worksheets("汇总表").Range("A1:I" & r).Value
    
20.    
    
21.       M = 2
    
22. f:    For i = M To r
    
23.            If Rng(i - 1, 5) = Rng(i, 5) And Rng(i, 7) >= 1 And Rng(i - 1, 8) = "□" Then '商品编码 与上一行相同， 且 数量大于等于1 ，且 上一行 核对列 为"□" （核对列 除了数量是小数外，全部是"□"）
    
24.             h = 2
    
25.             
    
26.             For j = i + 1 To r '查询有多少相同的行
    
27.                 If Rng(i, 5) = Rng(j, 5) And Rng(j, 7) >= 1 Then 'rng(j,7) 第7列是数量
    
28.                     h = h + 1 '累计行数
    
29.                 End If
    
30.             Next
    
31.             
    
32.             
    
33.             If h = 2 Then '两行相同 的商品编码
    
34.                 If ((Rng(i - 1, 7) + Rng(i, 7))) < 10 Then
    
35.                     Range("H" & i - 1) = "╮  "
    
36.                     Range("H" & i) = "╯" & (Rng(i - 1, 7) + Rng(i, 7)) & " " '1位数字，多加个空格，看起来整齐。
    
37.                 Else
    
38.                     Range("H" & i - 1) = "╮  "
    
39.                     Range("H" & i) = "╯" & (Rng(i - 1, 7) + Rng(i, 7))
    
40.                 End If
    
41.             ElseIf h = 3 Then '三行相同 的商品编码
    
42.                 Range("H" & i - 1) = "─╮"
    
43.                 Range("H" & i) = Rng(i - 1, 7) + Rng(i, 7) + Rng(i + 1, 7) '奇数行 中间行汇总数量
    
44.                 Range("H" & i + 1) = "─╯"
    
45.             ElseIf h = 4 Then
    
46.                 Range("H" & i - 1) = "─╮"
    
47.                 Range("H" & i) = "│"
    
48.                 Range("H" & i + 1) = Rng(i - 1, 7) + Rng(i, 7) + Rng(i + 1, 7) + Rng(i + 2, 7) '偶数行 偏下一行汇总数量
    
49.                 Range("H" & i + 2) = "─╯"
    
50.             ElseIf h = 5 Then
    
51.                 Range("H" & i - 1) = "─╮"
    
52.                 Range("H" & i) = "│"
    
53.                 Range("H" & i + 1) = Rng(i - 1, 7) + Rng(i, 7) + Rng(i + 1, 7) + Rng(i + 2, 7) + Rng(i + 3, 7)
    
54.                 Range("H" & i + 2) = "│"
    
55.                 Range("H" & i + 3) = "─╯"
    
56. '这里只汇总5行 相同的货品，附件中代码写了汇总17行
    
57.             End If
    
58.             M = i + h
    
59.             GoTo f
    
60.            End If
    
61.     Next
    
62. 
    
63.     Range("F2:H" & r).Select '选择 需要打印的 区域
    
64.     Application.ScreenUpdating = False
    
65. '------------------------------------------------------------------------打印 汇总
    
66.     If MsgBox("要先【打印】此汇总单吗？", vbQuestion + vbYesNo, "打印提示") = vbYes Then
    
67.         ActiveSheet.PageSetup.PrintArea = ActiveSheet.Range("F2:H" & r).Address '设置选择区域 为打印区域
    
68.         ActiveSheet.PrintOut Copies:=1, Collate:=True
    
69.     End If
    
70. End Sub
    
71. 
    
72. Private Sub CommandButton15_Click() '按单号 排序
    
73.     Dim r, i As Long
    
74.     Dim Rng As Variant
    
75.    
    
76. '-----------------------------------------------------------------------查询
    
77.     r = Worksheets("汇总表").Range("C65536").End(xlUp).Row
    
78.     Rng = Worksheets("汇总表").Range("A1:I" & r).Value
    
79.    
    
80.     Application.ScreenUpdating = False
    
81.    
    
82.     With ActiveSheet
    
83.         For i = 2 To r
    
84.            If Rng(i, 7) >= 1 Then
    
85.                .Cells(i, 8) = "□" '核对列设置 勾选框
    
86.            Else
    
87.                .Cells(i, 8) = "***" '数量是小数 另设置其他符号
    
88.            End If
    
89.         Next
    
90.     End With
    
91. '-----------------------------------------------------------------------排序
    
92.     ActiveSheet.Range("A1:I1000").Select
    
93.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=True _
    
94.         , Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
    
95.         xlSortNormal, DataOption2:=xlSortNormal
    
96.     Range("A2").Select
    
97.    
    
98.     Application.ScreenUpdating = True
    
99. End Sub
    

复制代码

附件是建好的一个测试文档。
明了的数量汇总显示.rar (26.82 KB, 下载次数: 26)

2017-5-4 11:29 上传

点击文件名下载附件

补充内容 (2018-7-27 18:42):
11楼有升级版
http://club.excelhome.net/thread-1343883-2-1.html

向東

版主，看看有没更好的方法？

microyip

这种的写法，效率太低了，数据一多就卡住了

microyip

不否认你这是你原创代码，但明显你不是想拿你的“原创”来分享，而是求助优化。

向東

microyip 发表于 2017-6-4 14:48
不否认你这是你原创代码，但明显你不是想拿你的“原创”来分享，而是求助优化。

麻烦指点一二，给个好思路。

microyip

向東 发表于 2017-6-4 15:56
麻烦指点一二，给个好思路。

全部读到数组里，在内存里运算，效率就提高很多了

向東

microyip 发表于 2017-6-4 16:40
全部读到数组里，在内存里运算，效率就提高很多了

是的，运算完了再写回去，处理大量数据需要汇总的必须这样做。
这段代码最令我受不了的就是汇总算法，它只是暂时解决了我工作上的需求，但是从编程角度看，一点都不优雅，太丑了！

microyip

基本上无需排序，只需要把资料读到数组里，然后字典重复求和就可解决问题了，而且速度保证秒完的。

向東

microyip 发表于 2017-6-4 17:10
基本上无需排序，只需要把资料读到数组里，然后字典重复求和就可解决问题了，而且速度保证秒完的。

字典用的不是太熟练，有空试试用字典，拿这个练手。

microyip

建议不是分享技术经验的，不要用“原创”来做标题，做标题党是不对的