[已解决]求几段VBA代码，感觉挺难写的，求前辈指点一下。

小新M

求几段VBA的代码，基本上都是我工作中处理excel遇到的问题，由于自己初学，感觉这处理这些太难了，求有经验的前辈看看，帮我写几段代码，然后我自己再慢慢的边学习边套用到自己的表格中。帮助我的人请你喝红牛

最佳答案

月排行榜 / 总排行榜

grf1973

2014-6-17 11:35

请看附件。

跳转到最佳答案楼层

grf1973

最后一个要求有点烦。先解决前面三个。

1. Sub 汇总()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Array("a", "b", "c", "d")   '要汇总的工作表
   
4.     For i = 0 To UBound(arr)
   
5.         x = arr(i)
   
6.         brr = Sheets(x).[a1].CurrentRegion   '要汇总的工作表数据入数组
   
7.         For k = 2 To UBound(brr)
   
8.             xkey = x & brr(k, 1)   '工作表名+代号为key
   
9.             d(xkey) = d(xkey) + brr(k, 2)     '金额为item
   
10.             d(x) = d(x) + brr(k, 2)    '本工作表所有金额之和
    
11.         Next
    
12.     Next
    
13.     brr = [a1:L9]
    
14.     For i = 4 To UBound(brr)
    
15.         x = brr(i, 1)   '工作表名
    
16.         s = d(x)   '本工作表所有金额之和
    
17.         For j = 2 To UBound(brr, 2) - 1
    
18.             xkey = x & brr(3, j)     '工作表名+代号
    
19.             If d.exists(xkey) Then
    
20.                 brr(i, j) = brr(i, j) + d(xkey)      '在当前表基础上累加字典值
    
21.                 s = s - d(xkey)
    
22.             End If
    
23.         Next
    
24.         brr(i, j) = brr(i, j) + s   '最后一列（工作表所有金额之和减去已累加过的数值）
    
25.     Next
    
26.     [a1:L9] = brr
    
27. End Sub
    

复制代码

小新M

grf1973 发表于 2014-6-17 10:37
最后一个要求有点烦。先解决前面三个。

谢谢   我的用户组没有权限发消息，请发消息给我你的支付宝。 顺遍解决一下 最后一个问题

grf1973

第4个要求

1. Sub 分析()
   
2.     arr = Array("a", "b", "c", "d")   '要汇总的工作表
   
3.     crr = [a5:i8]
   
4.     For i = 0 To UBound(arr)
   
5.         x = arr(i)
   
6.         brr = Sheets(x).[a1].CurrentRegion   '要汇总的工作表数据入数组
   
7.         maxx = 0: minx = 10000   'x组最大最小值初始化
   
8.         maxy = 0: miny = 10000   'y组最大最小值初始化
   
9.         For k = 2 To UBound(brr)
   
10.             dh = brr(k, 1): je = brr(k, 2)   '代号 、金额
    
11.             If Left(dh, 1) = 5 Then   'X组
    
12.                 If maxx < je Then maxx = je: dh1 = dh    'x组最大值
    
13.                 If minx > je Then minx = je: dh2 = dh    'x组最小值
    
14.             ElseIf Left(dh, 1) = 7 Then   'Y组
    
15.                 If maxy < je Then maxy = je: dh3 = dh  'y组最大值
    
16.                 If miny > je Then miny = je: dh4 = dh  'y组最小值
    
17.             End If
    
18.         Next
    
19.         Cells(5 + i, 2).Resize(1, 8) = Array(dh1, maxx, dh2, minx, dh3, maxy, dh4, miny)
    
20.     Next
    
21. End Sub
    
22. 
    

复制代码

grf1973

由于前面的汇总数是相同代号的累加，因此分析表中的最大最小值并不能完全对应。难道分析表中的最大最小值是针对汇总数来的？

小新M

grf1973 发表于 2014-6-17 10:59
由于前面的汇总数是相同代号的累加，因此分析表中的最大最小值并不能完全对应。难道分析表中的最大最小值是 ...

是的 最大值 最小值  确实是对应汇总表来取数的

grf1973

针对汇总表的分析。。。。。

1. Sub 分析()
   
2.     With Sheet1
   
3.         arr = .[a1:L7]    '汇总表
   
4.         .[a1:L7].Interior.ColorIndex = 0
   
5.         For i = 4 To UBound(arr)
   
6.             maxx = 0: minx = 10000   'x组最大最小值初始化
   
7.             maxy = 0: miny = 10000   'y组最大最小值初始化
   
8.             For j = 2 To UBound(arr, 2) - 1
   
9.                 dh = arr(3, j): je = arr(i, j) '代号 、金额
   
10.                 If Left(dh, 1) = 5 Then   'X组
    
11.                     If maxx < je Then maxx = je: dh1 = dh    'x组最大值
    
12.                     If minx > je Then minx = je: dh2 = dh    'x组最小值
    
13.                 ElseIf Left(dh, 1) = 7 Then   'Y组
    
14.                     If maxy < je Then maxy = je: dh3 = dh  'y组最大值
    
15.                     If miny > je Then miny = je: dh4 = dh  'y组最小值
    
16.                 End If
    
17.             Next
    
18.             Cells(1 + i, 2).Resize(1, 8) = Array(dh1, maxx, dh2, minx, dh3, maxy, dh4, miny)
    
19.             .Rows(i).Find(maxx, lookat:=xlWhole).Interior.Color = vbRed
    
20.             .Rows(i).Find(maxy, lookat:=xlWhole).Interior.Color = vbRed
    
21.             .Rows(i).Find(minx, lookat:=xlWhole).Interior.Color = vbYellow
    
22.             .Rows(i).Find(miny, lookat:=xlWhole).Interior.Color = vbYellow
    
23.         Next
    
24.     End With
    
25. End Sub
    

复制代码

grf1973

请看附件。

小新M

grf1973 发表于 2014-6-17 11:35
请看附件。

完美  非常感谢    付出就有收获 请消息给我你的支付宝，小小心意请你和红牛了。

grf1973

完全不用，只为兴趣。