How to perform SumIf using VBA on an array in Excel

问题

I'm trying to come up with the fastest way to perform a SumIf function in Excel on a dataset that has approx. 110'000 lines. I've come up with three ways, but none of them are satisfying.

Here the first one I tried: Execution time on my PC 100 seconds!

    Sub Test1_WorksheetFunction()

Dim MaxRow As Long, MaxCol As Long
Dim i As Long
Dim StartTimer, EndTimer, UsedTime

StartTimer = Now()

With wsTest
    MaxRow = .UsedRange.Rows.Count
    MaxCol = .UsedRange.Columns.Count

    For i = 2 To MaxRow
        .Cells(i, 4) = WorksheetFunction.SumIf(wsData.Range("G2:G108840"), .Cells(i, 1), wsData.Range("R2:R108840"))
    Next i

End With

EndTimer = Now()
MsgBox (DateDiff("s", StartTimer, EndTimer))

End Sub

Here is the second Method: Execution Time a bit better at 55 seconds

Sub Test2_Formula_and_Copy()

Dim MaxRow As Long, MaxCol As Long
Dim i As Long
Dim StartTimer, EndTimer, UsedTime

StartTimer = Now()

With wsTest
    MaxRow = .UsedRange.Rows.Count
    MaxCol = .UsedRange.Columns.Count

    Range("D2").Select
    ActiveCell.FormulaR1C1 = _
        "=SUMIF(Tabelle1[KUNDENBESTELLNR],Test!RC[-3],Tabelle1[ANZAHL NACHFRAGE])"
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D6285")
    Range("D2:D6285").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

End With

EndTimer = Now()
MsgBox (DateDiff("s", StartTimer, EndTimer))

End Sub

Third attempt: Execution so slow it never finished.

Sub Test3_Read_in_Array()

Dim MaxRow As Long, MaxCol As Long
Dim SearchRange() As String, SumRange() As Long
Dim i As Long, j As Long, k
Dim StartTimer, EndTimer, UsedTime
Dim TempValue

StartTimer = Now()

With wsData
    MaxRow = .UsedRange.Rows.Count
    ReDim SearchRange(1 To MaxRow)
    ReDim SumRange(1 To MaxRow)
    For i = 1 To MaxRow
        SearchRange(i) = .Range("G" & (1 + i)).Value
        SumRange(i) = .Range("R" & (1 + i)).Value
    Next i
End With

With wsTest
    MaxRow = .UsedRange.Rows.Count
    For i = 2 To MaxRow
        For j = LBound(SearchRange) To UBound(SearchRange)
            k = .Cells(i, 1).Value
            If k = SearchRange(j) Then
            TempValue = TempValue + SumRange(j)
            End If
        Next j
        .Cells(i, 4) = TempValue
    Next i
End With


EndTimer = Now()
MsgBox (DateDiff("s", StartTimer, EndTimer))

End Sub

Clearly I have not yet mastered VBA (or any other programming language for that matter). Can someone help me in getting this to be efficient? There must be a way! Right?

Thanks!

回答1:

I’d been searching for a faster method for calculating Sumifs for some time when I came up with the following solution. Instead of using Sumifs, you concatenate the values used in the criteria ranges as a single value, then using simple If formulas – combined with one range Sort – you achieve the same results as if you’d used Sumifs.

In my own case, using Sumifs with 25K rows and 2 criteria ranges to evaluate was taking 18.4 seconds on average – using the If and Sort method, it was taking 0.67 seconds on average.

 Sub FasterThanSumifs()
    'FasterThanSumifs Concatenates the criteria values from columns A and B -
    'then uses simple IF formulas (plus 1 sort) to get the same result as a sumifs formula

    'Columns A & B contain the criteria ranges, column C is the range to sum
    'NOTE: The data is already sorted on columns A AND B

    'Concatenate the 2 values as 1 - can be used to concatenate any number of values
    With Range("D2:D25001")
        .FormulaR1C1 = "=RC[-3]&RC[-2]"
        .Value = .Value
    End With

    'If formula sums the range-to-sum where the values are the same
    With Range("E2:E25001")
        .FormulaR1C1 = "=IF(RC[-1]=R[-1]C[-1],RC[-2]+R[-1]C,RC[-2])"
        .Value = .Value
    End With

    'Sort the range of returned values to place the largest values above the lower ones
    Range("A1:E25001").Sort Key1:=Range("D1"), Order1:=xlAscending, _
    Key2:=Range("E1"), Order2:=xlDescending, Header:=xlYes
    Sheet1.Sort.SortFields.Clear

    'If formula returns the maximum value for each concatenated value match &
    'is therefore the equivalent of using a Sumifs formula
    With Range("F2:F25001")
        .FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],R[-1]C,RC[-1])"
        .Value = .Value
    End With

    End Sub

回答2:

Give this a whirl

Sub test()
    StartTimer = Now()
    With ActiveSheet.Range("D2:D6285")
        .FormulaR1C1 = "=SUMIF(Tabelle1[KUNDENBESTELLNR],Test!RC[-3],Tabelle1[ANZAHL NACHFRAGE])"
        .Value = .Value
    End With
    EndTimer = Now()
    MsgBox (DateDiff("s", StartTimer, EndTimer))
End Sub

回答3:

My version was inspired by kevin999's solution.

++ works with unsorted sumif criteria
++ will bring the rows back to the original order

-- doesn't support multiple criteria columns

Please note: The columns containing the criteria and the data to sum up must be one next to another.

Option Explicit

Sub Execute()
Call FasterThanSumifs(1)
End Sub

Private Sub FasterThanSumifs(Criteria As Long)
'Expects two coloumns next to each other:
'SumIf criteria (left side)
'SumIf data range (right side)

Dim SumRange, DataNumber, HelpColumn, SumifColumn, LastRow As Long
SumRange = Criteria + 1
DataNumber = Criteria + 2
HelpColumn = Criteria + 3
SumifColumn = Criteria + 4
LastRow = UF_LetzteZeile()

Columns(DataNumber).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns(HelpColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns(SumifColumn).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

'Remember data order
Cells(2, DataNumber).Value = 1
Cells(2, DataNumber).AutoFill Destination:=Range(Cells(2, DataNumber), Cells(LastRow, DataNumber)), Type:=xlFillSeries

'Sort the range of returned values to place the largest values above the lower ones
Range(Cells(1, Criteria), Cells(LastRow, SumifColumn)).Sort Key1:=Columns(Criteria), Order1:=xlAscending, Header:=xlYes
ActiveSheet.Sort.SortFields.Clear

'If formula sums the range-to-sum where the values are the same
With Range(Cells(2, HelpColumn), Cells(LastRow, HelpColumn))
    .FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3], RC[-2] + R[-1]C,RC[-2])"
    '.Value = .Value
End With

'If formula returns the maximum value for each concatenated value match &
'is therefore the equivalent of using a Sumifs formula
With Range(Cells(2, SumifColumn), Cells(LastRow, SumifColumn))
    .FormulaR1C1 = "=IF(RC[-4]=R[+1]C[-4], R[+1]C, RC[-1])"
    .Value = .Value
End With

Columns(HelpColumn).Delete

'Sort the range in the original order
Range(Cells(1, Criteria), Cells(LastRow, SumifColumn)).Sort Key1:=Columns(DataNumber), Order1:=xlAscending, Header:=xlYes
ActiveSheet.Sort.SortFields.Clear

Columns(DataNumber).Delete

End Sub

来源：https://stackoverflow.com/questions/12975530/how-to-perform-sumif-using-vba-on-an-array-in-excel