vba 數組和 scripting.dictionary 中的 SUMIFS 更快

Question

我想使用 vba sumifs 數組和 scripting.dictionary 因為有十萬條記錄可能是最好的解決方案。 信息表“DBALL”是源，表“RECON”是結果。 我還在下面找到了 vba 代碼，但它與結果不匹配。

信息公式表 "RECON" 列 B "In" = SUMIFS(DBALL:$A$2,$A$5:DBALL,$C$2,$C$5:RECON,$A2,DBALL!$B$2:$B$5,RECON !B$1)

信息公式表 "RECON" 列 c "Out" = SUMIFS(DBALL:$A$2,$A$5:DBALL,$C$2,$C$5:RECON,$A2,DBALL!$B$2:$B$5,RECON !C$1)

信息公式表“偵察”列 d“差異”= B2-C2

謝謝

  Sub SUMIFSFASTER()
    
    Dim arr, ws, rng As Range, keyCols, valueCol As Long, destCol As Long, i As Long, frm As String, sep As String
    Dim t, dict, arrOut(), arrValues(), v, tmp, n As Long
    
    keyCols = Array(2, 3)  'these columns form the composite key
    valueCol = 1             'column with values (for sum)
    destCol = 4               'destination for calculated values
    
    t = Timer
    
    Set ws = Sheets("DBALL")
    Set rng = ws.Range("A1").CurrentRegion
    n = rng.Rows.Count - 1
    Set rng = rng.Offset(1, 0).Resize(n) 'exclude headers
    
    'build the formula to create the row "key"
    For i = 0 To UBound(keyCols)
        frm = frm & sep & rng.Columns(keyCols(i)).Address
        sep = "&""|""&"
    Next i
    arr = ws.Evaluate(frm)  'get an array of composite keys by evaluating the formula
    arrValues = rng.Columns(valueCol).Value  'values to be summed
    ReDim arrOut(1 To n, 1 To 1)             'this is for the results
    
    Set dict = CreateObject("scripting.dictionary")
    'first loop over the array counts the keys
    For i = 1 To n
        v = arr(i, 1)
        If Not dict.exists(v) Then dict(v) = Array(0, 0) 'count, sum
        tmp = dict(v) 'can't modify an array stored in a dictionary - pull it out first
        tmp(0) = tmp(0) + 1                 'increment count
        tmp(1) = tmp(1) + arrValues(i, 1)   'increment sum
        dict(v) = tmp                       'return the modified array
    Next i
    
    'second loop populates the output array from the dictionary
    For i = 1 To n
        arrOut(i, 1) = dict(arr(i, 1))(1)                       'sumifs
        'arrOut(i, 1) = dict(arr(i, 1))(0)                      'countifs
        'arrOut(i, 1) = dict(arr(i, 1))(1) / dict(arr(i, 1))(0) 'averageifs
    Next i
    'populate the results
    rng.Columns(destCol).Value = arrOut
    
    Debug.Print "Checked " & n & " rows in " & Timer - t & " secs"

End Sub

資源

結果

Answer 1

正如評論中所說，使用 pivot 表可能是更好的解決方案。 電源 pivot。

如果您正在尋求 VBA 的解決方案並且想要使用字典，我可能會使用以下代碼。

首先，您需要創建一個 class cVal來存儲您所追求的值

Option Explicit

Public qtyIn As Double
Public qtyOut As Double

然后你可以使用下面的代碼

Option Explicit

Sub useDict()

    Const COL_VAL = 1
    Const COL_INOUT = 2
    Const COL_COMBINE = 3
    Const GRO_IN = "IN"
    Const GRO_OUT = "OUT"

    Dim rg As Range, ws As Worksheet
    
    ' Get the range with the data
    Set ws = Worksheets("DBALL")
    Set rg = ws.Range("A1").CurrentRegion
    Set rg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
        
    Dim vDat As Variant
    vDat = rg
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim Key As Variant, gro As Variant
    Dim i As Long, sngVal  As cVal
    For i = LBound(vDat, 1) To UBound(vDat, 1)
    
        ' Key of the dictionary
        Key = vDat(i, COL_COMBINE)
        ' trim the value and do not consider upper/lower case
        gro = UCase(Trim(vDat(i, COL_INOUT)))
                
        If dict.Exists(Key) Then
            ' just increase the "member" values of the already stored object
            Set sngVal = dict(Key)
            With sngVal
                If gro = GRO_IN Then
                    .qtyIn = .qtyIn + vDat(i, COL_VAL)
                End If
                If gro = GRO_OUT Then
                    .qtyOut = .qtyOut + vDat(i, COL_VAL)
                End If
            End With
        
        Else
            ' Create a new object which stores the summed values for "IN" resp "OUT"
            Set sngVal = New cVal
            With sngVal
                If gro = GRO_IN Then
                    .qtyIn = vDat(i, COL_VAL)
                End If
                If gro = GRO_OUT Then
                    .qtyOut = vDat(i, COL_VAL)
                End If
            End With
            dict.Add Key, sngVal

        End If
    
    Next i
    
    
    ' write Dictionary
    
    ' put the values of the dictionary in an array
    ' this is faster than writing each single line directly to the sheet
    ReDim vDat(1 To dict.Count, 1 To 4)
    i = 1
    For Each Key In dict.Keys
        vDat(i, 1) = Key
        vDat(i, 2) = dict(Key).qtyIn
        vDat(i, 3) = dict(Key).qtyOut
        vDat(i, 4) = Abs(dict(Key).qtyIn - dict(Key).qtyOut)
        i = i + 1
    Next Key
    
    'write Header
    Set rg = Worksheets("RECON").Range("A1")
    Set rg = rg.Resize(, 4)
    rg.Clear
    rg = Array("COMBINE", "In", "Out", "Diff")
        
    Set rg = Worksheets("RECON").Range("A2")
    Set rg = rg.Resize(dict.Count, 4)
    rg.Clear
    rg = vDat

End Sub

但我懷疑它是否比 Pivot 表更快