vab替代Sumif求和

michaelaa

麻烦老师帮忙改一下代码，如果是不连续的列，如何求和，改了几次不成功，感谢@！

今铭昔

michaelaa

今铭昔 发表于 2022-5-16 12:36

感谢老师的回复。

tel3033

1. Sub byDD()
   
2.     Dim i%, arr, d As Object
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheet2.[a1].CurrentRegion
   
5.         For i = 2 To UBound(arr)
   
6.             d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 5)
   
7.         Next
   
8.     arr = Sheet1.[a1].CurrentRegion
   
9.         For i = 2 To UBound(arr)
   
10.             arr(i, 3) = d(arr(i, 1))
    
11.         Next
    
12.    Sheet1.[c2].Resize(i - 2, 1) = Empty
    
13.    Sheet1.[a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
14. End Sub
    

复制代码

michaelaa

tel3033 发表于 2022-5-16 12:44

老师，我这边有个新的要求，就是多列的求和，还存在不连续的，可以实现吗？

tel3033

1. Sub byDD()
   
2.     Dim i%, arr, d As Object
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheet2.[a1].CurrentRegion
   
5.         For i = 2 To UBound(arr)
   
6.             For j = 5 To UBound(arr, 2)
   
7.                 s = arr(i, 1) & "|" & arr(1, j)
   
8.                 d(s) = d(s) + arr(i, j)
   
9.             Next
   
10.         Next
    
11.     arr = Sheet1.[a1].CurrentRegion
    
12.         For i = 2 To UBound(arr)
    
13.             For j = 3 To UBound(arr, 2)
    
14.                 s = arr(i, 1) & "|" & arr(1, j)
    
15.                 arr(i, j) = d(s)
    
16.             Next
    
17.         Next
    
18.    Sheet1.[c2].Resize(i - 2, 7) = Empty
    
19.    Sheet1.[a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
20. End Sub

复制代码

ykcbf1100

michaelaa 发表于 2022-5-16 14:34
老师，我这边有个新的要求，就是多列的求和，还存在不连续的，可以实现吗？

是这意思吗？

michaelaa

ykcbf1100 发表于 2022-5-16 15:24
是这意思吗？

是的，谢谢老师

洋务德雷

这个用数据透视表不就可以了吗？

ericxzhou

1. Sub test()
   
2.     Dim sql$, arr
   
3.     sql = "select num from [Sheet2$] a, (select 姓名,sum(数量) as num from [Sheet1$] group by 姓名) b where a.姓名 = b.姓名"
   
4.     arr = GET_SQL(sql, False)
   
5.     Sheets("Sheet2").Activate
   
6.     [b2].Resize(UBound(arr) + 1) = arr
   
7. End Sub
   
8. 
   
9. Public Function GET_SQL(strSQL As String, Optional HasHeader As Boolean = True) As Variant()
   
10.     Dim Cn, Rs, arr(), i%, j%
    
11.     Set Cn = CreateObject("ADODB.Connection")
    
12.     Set Rs = CreateObject("ADODB.Recordset")
    
13.     If Application.Version < 12 Then
    
14.         Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    
15.     Else
    
16.         Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    
17.     End If
    
18.     Rs.Open strSQL, Cn, 1, 3
    
19.     If HasHeader = True Then
    
20.         ReDim arr(0 To Rs.RecordCount, 0 To Rs.Fields.Count - 1)
    
21.         For i = 0 To Rs.Fields.Count - 1
    
22.            arr(0, i) = Rs.Fields(i).Name
    
23.         Next
    
24.         For i = 0 To Rs.RecordCount - 1
    
25.             For j = 0 To Rs.Fields.Count - 1
    
26.                 arr(i + 1, j) = Rs.Fields(j).Value
    
27.             Next
    
28.             Rs.MoveNext
    
29.         Next
    
30.     Else
    
31.          ReDim arr(0 To Rs.RecordCount - 1, 0 To Rs.Fields.Count - 1)
    
32.          For i = 0 To Rs.RecordCount - 1
    
33.              For j = 0 To Rs.Fields.Count - 1
    
34.                  arr(i, j) = Rs.Fields(j).Value
    
35.              Next
    
36.              Rs.MoveNext
    
37.          Next
    
38.          '注意用GetRows方法转置会遇到NULL转置报错的情况
    
39.     End If
    
40.     GET_SQL = arr
    
41.     Cn.Close
    
42.     Set Rs = Nothing
    
43.     Set Cn = Nothing
    
44. End Function
    
45. 
    

复制代码