[已解决]VBA统计同一公司、同一药品的进货数据与销售数量

yjwdjfqb

VBA统计同一公司、同一药品的进货数据与销售数量

如附件中的　模拟数据

请老师们帮帮忙，谢谢老师们了！
VBA统计同一公司、同一药品的进货数据与销售数量.rar (23.89 KB, 下载次数: 36)

2014-10-30 10:57 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-10-30 12:03

1. Sub demo()
   
2.     Dim d As Object
   
3.     Dim arr, result(), temp(1 To 1024, 1 To 3), temp2
   
4.     Dim dKeys, dItems
   
5.     Dim i&, j&, lPos&, str$, lPos1&, strRow$, k&
   
6.    
   
7.     arr = Worksheets("数据源").Range("a1").CurrentRegion.Value
   
8.    
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     For i = 2 To UBound(arr)
    
11.         str = arr(i, 3) & "#" & arr(i, 4)
    
12.         If d.exists(str) Then
    
13.             lPos1 = d(str)
    
14.         Else
    
15.             lPos = lPos + 1
    
16.             d(str) = lPos
    
17.             lPos1 = lPos
    
18.         End If
    
19.         temp(lPos1, 2) = temp(lPos1, 2) + arr(i, 5)
    
20.         temp(lPos1, 3) = temp(lPos1, 3) + arr(i, 11)
    
21.         temp(lPos1, 1) = temp(lPos1, 1) & i & ","
    
22.     Next
    
23.    
    
24.     ReDim result(1 To UBound(arr) + 1 + d.Count, 1 To UBound(arr, 2))
    
25.     dKeys = d.keys: dItems = d.items
    
26.     lPos = 2
    
27.     For k = LBound(arr, 2) To UBound(arr, 2)
    
28.         result(1, k) = arr(1, k)
    
29.     Next
    
30.     Application.ScreenUpdating = False
    
31.     Sheet1.UsedRange.Clear
    
32.     For i = LBound(dKeys) To UBound(dKeys)
    
33.         temp2 = Split(temp(i + 1, 1), ",")
    
34.         For j = LBound(temp2) To UBound(temp2) - 1
    
35.             lPos1 = temp2(j)
    
36.             For k = LBound(arr, 2) To UBound(arr, 2)
    
37.                 result(lPos, k) = arr(lPos1, k)
    
38.             Next
    
39.             lPos = lPos + 1
    
40.         Next
    
41. 
    
42.         result(lPos, 3) = result(lPos - 1, 3)
    
43.         result(lPos, 4) = result(lPos - 1, 4)
    
44.         result(lPos, 5) = temp(i + 1, 2)
    
45.         result(lPos, 11) = temp(i + 1, 3)
    
46.         With Sheet1.Rows(lPos)
    
47.             .Font.Bold = True
    
48.             .Font.Color = vbRed
    
49.         End With
    
50.         lPos = lPos + 1
    
51.     Next
    
52.     With Sheet1
    
53.         .Range("a1").Resize(lPos, 11).Value = result
    
54.     End With
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "统计完成"
    
57. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

用数透表应该是很方便的了。

或者

改用SQL来实现。

hwc2ycy

你的效果实际上就是分类汇总能实用了。何必再用VBA呢。

yjwdjfqb

hwc2ycy 发表于 2014-10-30 11:19
你的效果实际上就是分类汇总能实用了。何必再用VBA呢。

老师，可以帮我录个动画吗，谢谢了老师了！

yjwdjfqb

hwc2ycy 发表于 2014-10-30 11:17
用数透表应该是很方便的了。

或者

老师你好，能帮我录制个数据透视表的动画吗，谢谢老师了！

hwc2ycy

1. Sub demo()
   
2.     Dim d As Object
   
3.     Dim arr, result(), temp(1 To 1024, 1 To 3), temp2
   
4.     Dim dKeys, dItems
   
5.     Dim i&, j&, lPos&, str$, lPos1&, strRow$, k&
   
6.    
   
7.     arr = Worksheets("数据源").Range("a1").CurrentRegion.Value
   
8.    
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     For i = 2 To UBound(arr)
    
11.         str = arr(i, 3) & "#" & arr(i, 4)
    
12.         If d.exists(str) Then
    
13.             lPos1 = d(str)
    
14.         Else
    
15.             lPos = lPos + 1
    
16.             d(str) = lPos
    
17.             lPos1 = lPos
    
18.         End If
    
19.         temp(lPos1, 2) = temp(lPos1, 2) + arr(i, 5)
    
20.         temp(lPos1, 3) = temp(lPos1, 3) + arr(i, 11)
    
21.         temp(lPos1, 1) = temp(lPos1, 1) & i & ","
    
22.     Next
    
23.    
    
24.     ReDim result(1 To UBound(arr) + 1 + d.Count, 1 To UBound(arr, 2))
    
25.     dKeys = d.keys: dItems = d.items
    
26.     lPos = 2
    
27.     For k = LBound(arr, 2) To UBound(arr, 2)
    
28.         result(1, k) = arr(1, k)
    
29.     Next
    
30.     Application.ScreenUpdating = False
    
31.     Sheet1.UsedRange.Clear
    
32.     For i = LBound(dKeys) To UBound(dKeys)
    
33.         temp2 = Split(temp(i + 1, 1), ",")
    
34.         For j = LBound(temp2) To UBound(temp2) - 1
    
35.             lPos1 = temp2(j)
    
36.             For k = LBound(arr, 2) To UBound(arr, 2)
    
37.                 result(lPos, k) = arr(lPos1, k)
    
38.             Next
    
39.             lPos = lPos + 1
    
40.         Next
    
41. 
    
42.         result(lPos, 3) = result(lPos - 1, 3)
    
43.         result(lPos, 4) = result(lPos - 1, 4)
    
44.         result(lPos, 5) = temp(i + 1, 2)
    
45.         result(lPos, 11) = temp(i + 1, 3)
    
46.         With Sheet1.Rows(lPos)
    
47.             .Font.Bold = True
    
48.             .Font.Color = vbRed
    
49.         End With
    
50.         lPos = lPos + 1
    
51.     Next
    
52.     With Sheet1
    
53.         .Range("a1").Resize(lPos, 11).Value = result
    
54.     End With
    
55.     Application.ScreenUpdating = True
    
56.     MsgBox "统计完成"
    
57. End Sub
    

复制代码

hwc2ycy

好久没写了，代码有点复杂，其实先排好序，效率应该会更高。

yjwdjfqb

hwc2ycy 发表于 2014-10-30 11:19
你的效果实际上就是分类汇总能实用了。何必再用VBA呢。

老师你好，能帮我录制个数据透视的动画吗，想学习下数据透视的方法，谢谢老师了！

yjwdjfqb

请老师们用数据透视的方法做这个附件，帮我做个数据透视表的动画教程。
谢谢老师们了！

yjwdjfqb

hwc2ycy 发表于 2014-10-30 12:03

老师你好，帮我写下这几句的代码好吧，谢谢了老师！