[已解决]价格汇总代码

642070295

各位大师，以下按价格汇总用代码怎么表达？先谢了！

日期	金额	价格	销量
2014-3-19	745.5	10.5	71
2014-3-18	367.5	10.5	35
2014-3-17	840	10.5	80
2014-4-1	370.6	10.9	34
2014-3-28	403.2	11.2	36
2014-3-16	134.4	11.2	12
2014-3-21	241.5	11.5	21
2014-3-22	609.5	11.5	53
2014-3-27	264.5	11.5	23
2014-3-20	413	11.8	35
2014-3-31	755.2	11.8	64
2014-4-6	511.7	11.9	43
2014-3-29	580.8	12.1	48
2014-3-26	264.6	12.6	21
2014-4-5	466.2	12.6	37
2014-3-30	37.8	12.6	3
2014-3-23	1196.8	13.6	88
2014-4-2	136	13.6	10
2014-4-3	538.2	13.8	39
2014-4-4	786.6	13.8	57
2014-3-25	858	14.3	60
2014-3-24	1489.6	15.2	98
效果要求说明：按“价格”分别汇总“金额”和“销量”。

最佳答案

月排行榜 / 总排行榜

qh8600

2014-5-16 17:52

642070295 发表于 2014-5-16 17:45
要求把汇总结果在原列里显示，该怎么改代码呢？

Private Sub CommandButton1_Click()
Dim ar, br, str As String, d As Object, i, j, r As String '定义变量
    Set d = CreateObject("Scripting.Dictionary")          '字典对象
    ar = Sheet1.Range("A1").CurrentRegion                 '把单元格赋值给变量
    ReDim br(1 To UBound(ar), 1 To 3)                     '重新定义数组大小
    For i = 2 To UBound(ar)                               '循环变量从2到数组的最大行
        str = ar(i, 3)                                    '把数组爱人ar的第三列赋值给变量str
        If Not d.Exists(str) Then                         '判断字典中没有变量str
            Cnt = Cnt + 1                                 '累加
            d(str) = Cnt                                  '写入字典
            br(Cnt, 2) = ar(i, 3)                         '给数组br赋值
         End If
        r = d(str)                                         '字典赋值给变量

        If ar(i, 1) <> "" Then br(r, 1) = Round(br(r, 1) + ar(i, 2)) '金额累加
        If ar(i, 3) <> "" Then br(r, 3) = Round(br(r, 3) + ar(i, 4)) '销量累加
    Next i
    With Sheet1
        .Range(.Cells(2, 2), .Cells(UBound(ar), 4)).ClearContents     '清空要写入的单元格区域
        .Cells(2, 2).Resize(Cnt, 3) = br                             '写入数组
    End With
End Sub
现在改为B2单元格为顶点的区域

跳转到最佳答案楼层

qh8600

能不能上传个附件

windimi007

请测试！以后请压缩Excel文件后上传！{:3512:}

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim ar, br(1 To 10000, 1 To 3)
   
4.     Dim i As Long, j As Long, rw As Long
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ar = Cells(1, 1).CurrentRegion
   
7.     j = 1: br(1, 1) = "价格": br(1, 2) = "金额": br(1, 3) = "销量"
   
8.     For i = 2 To UBound(ar)
   
9.         If d.exists(ar(i, 3)) Then
   
10.             rw = d(ar(i, 3))
    
11.             br(rw, 2) = br(rw, 2) + ar(i, 2)
    
12.             br(rw, 3) = br(rw, 3) + ar(i, 4)
    
13.         Else
    
14.             j = j + 1
    
15.             d.Add ar(i, 3), j
    
16.             br(j, 1) = ar(i, 3)
    
17.             br(j, 2) = ar(i, 2)
    
18.             br(j, 3) = ar(i, 4)
    
19.         End If
    
20.     Next i
    
21.     With Cells(1, 7)
    
22.         .Resize(Rows.Count, 3).ClearContents
    
23.         .Resize(j, 3) = br
    
24.         .Resize(, 3).EntireColumn.AutoFit
    
25.     End With
    
26. End Sub
    

复制代码

youfang

用透视表比较好做
坐等代码

qh8600

工作簿1.rar (18.15 KB, 下载次数: 13)

2014-5-16 14:09 上传

点击文件名下载附件

qh8600

windimi007 发表于 2014-5-16 14:02
请测试！以后请压缩Excel文件后上传！

这个今天已经写了3遍了，练练手
http://www.excelpx.com/thread-324997-1-1.html 这个是第1遍
当然老师写的还是要学习的,求带

642070295

qh8600 发表于 2014-5-16 14:09

辛苦一下5楼的楼主能注解一下代码吗？

qh8600

642070295 发表于 2014-5-16 14:47
辛苦一下5楼的楼主能注解一下代码吗？

1. Private Sub CommandButton1_Click()
   
2. Dim ar, br, str As String, d As Object, i, j, r As String '定义变量
   
3.     Set d = CreateObject("Scripting.Dictionary")          '字典对象
   
4.     ar = Sheet1.Range("A1").CurrentRegion                 '把单元格赋值给变量
   
5.     ReDim br(1 To UBound(ar), 1 To 3)                     '重新定义数组大小
   
6.     For i = 2 To UBound(ar)                               '循环变量从2到数组的最大行
   
7.         str = ar(i, 3)                                    '把数组爱人ar的第三列赋值给变量str
   
8.         If Not d.Exists(str) Then                         '判断字典中没有变量str
   
9.             Cnt = Cnt + 1                                 '累加
   
10.             d(str) = Cnt                                  '写入字典
    
11.             br(Cnt, 2) = ar(i, 3)                         '给数组br赋值
    
12.          End If
    
13.         r = d(str)                                         '字典赋值给变量
    
14.          
    
15.         If ar(i, 1) <> "" Then br(r, 1) = Round(br(r, 1) + ar(i, 2)) '金额累加
    
16.         If ar(i, 3) <> "" Then br(r, 3) = Round(br(r, 3) + ar(i, 4)) '销量累加
    
17.     Next i
    
18.     With Sheet1
    
19.         .Range(Cells(2, 8), Cells(UBound(ar), 10)).ClearContents     '清空要写入的单元格区域
    
20.         .Cells(2, 8).Resize(Cnt, 3) = br                             '写入数组
    
21.     End With
    
22. End Sub

复制代码

642070295

qh8600 发表于 2014-5-16 15:04

要求把汇总结果在原列里显示，该怎么改代码呢？

qh8600

642070295 发表于 2014-5-16 17:45
要求把汇总结果在原列里显示，该怎么改代码呢？

Private Sub CommandButton1_Click()
Dim ar, br, str As String, d As Object, i, j, r As String '定义变量
    Set d = CreateObject("Scripting.Dictionary")          '字典对象
    ar = Sheet1.Range("A1").CurrentRegion                 '把单元格赋值给变量
    ReDim br(1 To UBound(ar), 1 To 3)                     '重新定义数组大小
    For i = 2 To UBound(ar)                               '循环变量从2到数组的最大行
        str = ar(i, 3)                                    '把数组爱人ar的第三列赋值给变量str
        If Not d.Exists(str) Then                         '判断字典中没有变量str
            Cnt = Cnt + 1                                 '累加
            d(str) = Cnt                                  '写入字典
            br(Cnt, 2) = ar(i, 3)                         '给数组br赋值
         End If
        r = d(str)                                         '字典赋值给变量

        If ar(i, 1) <> "" Then br(r, 1) = Round(br(r, 1) + ar(i, 2)) '金额累加
        If ar(i, 3) <> "" Then br(r, 3) = Round(br(r, 3) + ar(i, 4)) '销量累加
    Next i
    With Sheet1
        .Range(.Cells(2, 2), .Cells(UBound(ar), 4)).ClearContents     '清空要写入的单元格区域
        .Cells(2, 2).Resize(Cnt, 3) = br                             '写入数组
    End With
End Sub
现在改为B2单元格为顶点的区域