如何用VBA数组写双条件求和

f8b1987

想写一个双条件求和的代码，终于完成了，但是采用一般循环方法速度太慢，想学习数组的写法，希望各位能帮助写一个。

我原来代码如下

1. Sub 双条件求和()Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   
2. 
   
3. For jj = 3 To 29
   
4.     '循环结果行数For k = 2 To 31
   
5.         '循环结果列数,
   
6. For Each sht In WorksheetsIf sht.Name <> "汇总" Then
   
7.                
   
8. For i = 2 To 300
   
9.                     '循环数据源行数If sht.Cells(i, "A") = Sheets("汇总").Cells(2, k) And sht.Cells(i, "B") = Sheets("汇总").Cells(jj, "A") Thenmysum = mysum + sht.Cells(i, "C")
   
10.                     End If
    
11.                 Next i
    
12.             End If
    
13.         Next sht
    
14.         Sheets("汇总").Cells(jj, k) = mysum
    
15.         mysum = 0
    
16.         '清空求和，继续循环求和
    
17.     Next k
    
18. Next jj
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

希望各位写个简易数组，让我学习一下。
双条件求和.rar (30.69 KB, 下载次数: 1036)

2012-5-5 20:55 上传

点击文件名下载附件

zzq0101

Sub 双条件求和()
tt = Timer
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
ahz = [a2].CurrentRegion
For jj = 2 To 28
    '循环结果行数,2:5行
    For k = 2 To 31
        '循环结果列数,B:F列
        For Each sht In Worksheets
            If sht.Name <> "汇总" Then
            aaa = sht.[a1].CurrentRegion
                For i = 2 To UBound(aaa)
                    '循环数据源行数
                    
                    If aaa(i, 1) = ahz(1, k) And aaa(i, 2) = ahz(jj, 1) Then
                        '如果G列=第一行的日期数据 且 同行I列=A列的地区
                        mysum = mysum + aaa(i, 3)
                    End If
                Next i
            End If
        Next sht
        ahz(jj, k) = mysum
        mysum = 0
        '清空求和，继续循环求和
    Next k
Next jj
[a2].Resize(UBound(ahz), UBound(ahz, 2)) = ahz
Application.ScreenUpdating = True
MsgBox Timer - tt
End Sub

zzq0101

1.125  秒 时间！

蓝天云朵

这个用字典加数组代码运行很快的。

huazai688

{:soso_e100:}

MRHUANGHESIR

Sub SUMPRODUCT2()
    '先将两个表拷在一起，这人代码我忘了
    Dim i&
    Dim a&
    Dim arr
    Dim dic As Object
    Dim dic1 As Object
   
    Sheet1.Range("a1").CurrentRegion.ClearContents
    arr = Sheet2.Range("a1").CurrentRegion
    Set dic1 = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        dic1(arr(i, 1)) = arr(i, 2)
    Next
   
    Sheet1.Range("B2").Resize(1, dic1.Count) = dic1.KEYS
    Sheet1.Range("A3").Resize(dic1.Count) = Application.Transpose(dic1.ITEMS)
   
    Set dic = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        dic(arr(i, 1) & " " & arr(i, 2)) = dic(arr(i, 1) & " " & arr(i, 2)) + arr(i, 3)
    Next
   
    arr = Sheet1.Range("A2:AE32")
    For i = 2 To UBound(arr)
        For a = 2 To UBound(arr, 2)
            arr(i, a) = dic(arr(1, a) & " " & arr(i, 1))
        Next
    Next
    Sheet1.Range("A2:AE32") = arr
   

woshibeibei

vba初学者，试着用字典写一下，时间也很短，不到1秒

Sub 多条件汇总()

t = Timer

Dim dic1 As Object

Set dic1 = CreateObject("scripting.dictionary")


    For Each sh In Worksheets
   
        If sh.Name <> "汇总" Then
        
            For i = 2 To sh.UsedRange.Rows.Count
            
                If dic1.exists(sh.Cells(i, 1) & sh.Cells(i, 2)) Then
               
                    dic1(sh.Cells(i, 1) & sh.Cells(i, 2)) = dic1(sh.Cells(i, 1) & sh.Cells(i, 2)) + sh.Cells(i, 3)
                    
                    Else
                    
                    dic1(sh.Cells(i, 1) & sh.Cells(i, 2)) = sh.Cells(i, 3)
               
                End If
               
            Next i
        
        End If
   
    Next sh


For a = 2 To 31

    For b = 3 To 29
   
        Sheet1.Cells(b, a) = dic1(Sheet1.Cells(2, a) & Sheet1.Cells(b, 1))
   
    Next b

Next a


dic1.RemoveAll

MsgBox Timer - t

End Sub

葱姜蒜拌胡萝卜

Sub 多个表格求和()
Application.ScreenUpdating = False
Dim a As Integer, b As Integer, m As Worksheet, sum, i

For a = 3 To Sheets("汇总").Range("a3").End(xlDown).Row
        For b = 2 To Sheets("汇总").Range("a2").End(xlToRight).Column
               
                For Each m In Worksheets
                    If m.Name <> "汇总" Then
                        For i = 2 To m.Range("a1").End(xlDown).Row
                        If Sheets("汇总").Cells(a, 1) = m.Cells(i, 2) And Sheets("汇总").Cells(2, b) = m.Cells(i, 1) Then
                        sum = sum + m.Cells(i, 3)
                        End If
                        Next
                    End If
                Next
            Cells(a, b) = sum
            
            sum = 0
            
        Next
Next
Application.ScreenUpdating = True
End Sub