[已解决]字典+数组求修改

爱很简单

字典数组循环查询求和，求修改

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-14 14:58

只在原代码上改了

1. Sub Macro1()
   
2.     On Error Resume Next
   
3.     Dim arr, brr, d, i&, s&, x&
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.Range("a1").CurrentRegion
   
6.     brr = Range("a6:g" & Range("a65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(brr)
   
8.         d(brr(i, 1)) = i
   
9.     Next
   
10.     For i = 3 To UBound(arr)
    
11.         x = d(arr(i, 7) & arr(i, 8) & arr(i, 9))
    
12.         y = d(arr(i, 7) & arr(i, 8))
    
13.         Z = d(arr(i, 7))
    
14.         
    
15.         brr(x, 2) = brr(x, 2) + arr(i, 2)
    
16.         brr(x, 3) = brr(x, 3) + arr(i, 4)
    
17.         brr(y, 2) = brr(y, 2) + arr(i, 2)
    
18.         brr(y, 3) = brr(y, 3) + arr(i, 4)
    
19.         brr(Z, 2) = brr(Z, 2) + arr(i, 2)
    
20.         brr(Z, 3) = brr(Z, 3) + arr(i, 4)
    
21.         
    
22.          If arr(i, 3) = "女" Then
    
23.             brr(x, 4) = brr(x, 4) + arr(i, 2)
    
24.             brr(x, 5) = brr(x, 5) + arr(i, 4)
    
25.             brr(y, 4) = brr(y, 4) + arr(i, 2)
    
26.             brr(y, 5) = brr(y, 5) + arr(i, 4)
    
27.             brr(Z, 4) = brr(Z, 4) + arr(i, 2)
    
28.             brr(Z, 5) = brr(Z, 5) + arr(i, 4)
    
29.         Else
    
30.             brr(x, 6) = brr(x, 6) + arr(i, 2)
    
31.             brr(x, 7) = brr(x, 7) + arr(i, 4)
    
32.             brr(y, 6) = brr(y, 6) + arr(i, 2)
    
33.             brr(y, 7) = brr(y, 7) + arr(i, 4)
    
34.             brr(Z, 6) = brr(Z, 6) + arr(i, 2)
    
35.             brr(Z, 7) = brr(Z, 7) + arr(i, 4)
    
36.         End If
    
37.     Next
    
38. [a6].Resize(UBound(brr), UBound(brr, 2)) = brr
    
39. End Sub
    

复制代码

跳转到最佳答案楼层

冥王

眼神不好使，没发现哪里需要修改的

爱很简单

冥王 发表于 2015-4-13 23:08
眼神不好使，没发现哪里需要修改的

按镇、按镇村查询求和时，无法查询！！！！

grf1973

只在原代码上改了

1. Sub Macro1()
   
2.     On Error Resume Next
   
3.     Dim arr, brr, d, i&, s&, x&
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.Range("a1").CurrentRegion
   
6.     brr = Range("a6:g" & Range("a65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(brr)
   
8.         d(brr(i, 1)) = i
   
9.     Next
   
10.     For i = 3 To UBound(arr)
    
11.         x = d(arr(i, 7) & arr(i, 8) & arr(i, 9))
    
12.         y = d(arr(i, 7) & arr(i, 8))
    
13.         Z = d(arr(i, 7))
    
14.         
    
15.         brr(x, 2) = brr(x, 2) + arr(i, 2)
    
16.         brr(x, 3) = brr(x, 3) + arr(i, 4)
    
17.         brr(y, 2) = brr(y, 2) + arr(i, 2)
    
18.         brr(y, 3) = brr(y, 3) + arr(i, 4)
    
19.         brr(Z, 2) = brr(Z, 2) + arr(i, 2)
    
20.         brr(Z, 3) = brr(Z, 3) + arr(i, 4)
    
21.         
    
22.          If arr(i, 3) = "女" Then
    
23.             brr(x, 4) = brr(x, 4) + arr(i, 2)
    
24.             brr(x, 5) = brr(x, 5) + arr(i, 4)
    
25.             brr(y, 4) = brr(y, 4) + arr(i, 2)
    
26.             brr(y, 5) = brr(y, 5) + arr(i, 4)
    
27.             brr(Z, 4) = brr(Z, 4) + arr(i, 2)
    
28.             brr(Z, 5) = brr(Z, 5) + arr(i, 4)
    
29.         Else
    
30.             brr(x, 6) = brr(x, 6) + arr(i, 2)
    
31.             brr(x, 7) = brr(x, 7) + arr(i, 4)
    
32.             brr(y, 6) = brr(y, 6) + arr(i, 2)
    
33.             brr(y, 7) = brr(y, 7) + arr(i, 4)
    
34.             brr(Z, 6) = brr(Z, 6) + arr(i, 2)
    
35.             brr(Z, 7) = brr(Z, 7) + arr(i, 4)
    
36.         End If
    
37.     Next
    
38. [a6].Resize(UBound(brr), UBound(brr, 2)) = brr
    
39. End Sub
    

复制代码