[已解决]循环查询求和，

爱很简单

循环查询求和，求好心人解决，谢谢

最佳答案

月排行榜 / 总排行榜

dsmch

2014-7-20 16:32

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, 5))
    
12.         brr(x, 2) = brr(x, 2) + arr(i, 2)
    
13.         brr(x, 3) = brr(x, 3) + arr(i, 4)
    
14.          If arr(i, 3) = "女" Then
    
15.             brr(x, 4) = brr(x, 4) + arr(i, 2)
    
16.             brr(x, 5) = brr(x, 5) + arr(i, 4)
    
17.         Else
    
18.             brr(x, 6) = brr(x, 6) + arr(i, 2)
    
19.             brr(x, 7) = brr(x, 7) + arr(i, 4)
    
20.         End If
    
21. Next
    
22. [a6].Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, s&, x&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Sheet1.Activate
   
5. arr = Range("a1").CurrentRegion
   
6. ReDim brr(1 To UBound(arr), 1 To 7)
   
7. For i = 3 To UBound(arr)
   
8.     If Not d.exists(arr(i, 5)) Then
   
9.         s = s + 1
   
10.         d(arr(i, 5)) = s
    
11.         brr(s, 1) = arr(i, 5)
    
12.         brr(s, 2) = arr(i, 2)
    
13.         brr(s, 3) = arr(i, 4)
    
14.         If arr(i, 3) = "女" Then
    
15.             brr(s, 4) = arr(i, 2)
    
16.             brr(s, 5) = arr(i, 4)
    
17.         Else
    
18.             brr(s, 6) = arr(i, 2)
    
19.             brr(s, 7) = arr(i, 4)
    
20.         End If
    
21.     Else
    
22.         x = d(arr(i, 5))
    
23.         brr(x, 2) = brr(x, 2) + arr(i, 2)
    
24.         brr(x, 3) = brr(x, 3) + arr(i, 4)
    
25.          If arr(i, 3) = "女" Then
    
26.             brr(x, 4) = brr(x, 4) + arr(i, 2)
    
27.             brr(x, 5) = brr(x, 5) + arr(i, 4)
    
28.         Else
    
29.             brr(x, 6) = brr(x, 6) + arr(i, 2)
    
30.             brr(x, 7) = brr(x, 7) + arr(i, 4)
    
31.         End If
    
32.     End If
    
33. Next
    
34. Sheet2.[a6].Resize(s, 7) = brr
    
35. End Sub
    
36. Sub Macro2()
    
37. Dim rng As Range
    
38. Sheet3.Activate
    
39. Set rng = Sheet1.Columns(6).Find([b6], lookat:=xlWhole)
    
40. If Not rng Is Nothing Then [e19] = rng.Row
    
41. End Sub

复制代码

dsmch

………………

爱很简单

dsmch 发表于 2014-7-20 09:34

谢谢您来了，我的意思是，问题一中的地址是固定的。不是从数据库中去取，地址最多24个，可以自己添加。能实现吗？谢谢你了

爱很简单

dsmch 发表于 2014-7-20 09:41
………………

谢谢您来了，我的意思是，问题一中的地址是固定的。不是从数据库中去取，地址最多24个，可以自己添加。能实现吗？谢谢你了

爱很简单

dsmch 发表于 2014-7-20 09:41
………………

谢谢您了，我的意思是，问题一中的地址是固定的。而不是从数据库中去取，地址最多24个，可以自己添加。能实现吗？谢谢你了

dsmch

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, 5))
    
12.         brr(x, 2) = brr(x, 2) + arr(i, 2)
    
13.         brr(x, 3) = brr(x, 3) + arr(i, 4)
    
14.          If arr(i, 3) = "女" Then
    
15.             brr(x, 4) = brr(x, 4) + arr(i, 2)
    
16.             brr(x, 5) = brr(x, 5) + arr(i, 4)
    
17.         Else
    
18.             brr(x, 6) = brr(x, 6) + arr(i, 2)
    
19.             brr(x, 7) = brr(x, 7) + arr(i, 4)
    
20.         End If
    
21. Next
    
22. [a6].Resize(UBound(brr), UBound(brr, 2)) = brr
    
23. End Sub

复制代码

爱很简单

dsmch 发表于 2014-7-20 16:32

您好，如果在两张表中查询求和，能不能实现这个功能，谢谢您，国庆节快乐。。。

爱很简单

dsmch 发表于 2014-7-20 16:32

您好，在么？？