Most efficient way to add cell values across congruent ranges in VBA?

问题

I need to sum the values two ranges of arbitrary (but identical) sizes. A1 in input1 gets summed with A1 in input2, then output to A1 in the output cell, etc. I need the end values, not formulas or links.

Using a loop this is much, much slower than expected (currently 15+ minutes.) It does not take that long to do it manually. Maybe I could pre-make some hidden worksheets filled an addition formula and then in VBA essentially mimic how a human would manually do it but it feels ass-backwards. Doing copy pastes across multiple worksheets should not be more efficient. Ditto link fiddling. Read them into an array maybe? But the output needs to be regular worksheet cells, not an array...

回答1:

pnuts' approach is certainly the best!

Generally, looping over the cells is usually the worst option in terms of performance. It tested a few methods with 1.2M cells, here's the result:

Looping each cell: 145,04s
Formula and store value: 6,89s
Formula and PasteSpecial Values: 3,44s
2x PasteSpecial Values&Add (pnuts approach): 0,72s

Here's the code I used - use method M3 for your task:

Option Explicit

Private Sub TimeMethods()
    Dim strAddress As String
    Dim dblStart As Double
    Application.Calculation = xlCalculationManual
    strAddress = "A1:X50000"

    ClearRange strAddress, Sheet3
    dblStart = Timer
    M0 strAddress, Sheet1, Sheet2, Sheet3
    Debug.Print "Looping each cell: " & Timer - dblStart

    ClearRange strAddress, Sheet3
    dblStart = Timer
    M1 strAddress, Sheet1, Sheet2, Sheet3
    Debug.Print "Formula and store value: " & Timer - dblStart

    ClearRange strAddress, Sheet3
    dblStart = Timer
    M2 strAddress, Sheet1, Sheet2, Sheet3
    Debug.Print "Formula and PasteSpecial Values: " & Timer - dblStart

    ClearRange strAddress, Sheet3
    dblStart = Timer
    M3 strAddress, Sheet1, Sheet2, Sheet3
    Debug.Print "2x PasteSpecial Values&Add: " & Timer - dblStart

    Application.Calculation = xlCalculationAutomatic
End Sub

Sub M0(strAddress As String, wsInput1 As Worksheet, wsInput2 As Worksheet, wsOutput As Worksheet)
    Dim rngTemp As Range
    Dim intCol As Integer, lngRow As Long
    Set rngTemp = wsInput1.Range(strAddress)
    For lngRow = rngTemp.Row To rngTemp.Row + rngTemp.Rows.Count
        For intCol = rngTemp.Column To rngTemp.Column + rngTemp.Columns.Count
            wsOutput.Cells(lngRow, intCol) = _
                wsInput1.Cells(lngRow, intCol) + _
                wsInput2.Cells(lngRow, intCol)
        Next intCol
    Next lngRow
End Sub

Sub M1(strAddress As String, wsInput1 As Worksheet, wsInput2 As Worksheet, wsOutput As Worksheet)
    With wsOutput.Range(strAddress)
        .FormulaR1C1 = "='" & wsInput1.Name & "'!RC+'" & wsInput2.Name & "'!RC"
        .Value = .Value
    End With
End Sub

Sub M2(strAddress As String, wsInput1 As Worksheet, wsInput2 As Worksheet, wsOutput As Worksheet)
    With wsOutput.Range(strAddress)
        .FormulaR1C1 = "='" & wsInput1.Name & "'!RC+'" & wsInput2.Name & "'!RC"
        .Copy
        .PasteSpecial xlPasteValues
    End With
End Sub

Sub M3(strAddress As String, wsInput1 As Worksheet, wsInput2 As Worksheet, wsOutput As Worksheet)
    Dim rngOutput As Range, rngInput As Range
    Set rngOutput = wsOutput.Range(strAddress)
    wsInput1.Range(strAddress).Copy
    rngOutput.PasteSpecial xlPasteValues
    wsInput2.Range(strAddress).Copy
    rngOutput.PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
End Sub

Sub ClearRange(strAddress As String, wsOutput As Worksheet)
    wsOutput.Range(strAddress).Clear
End Sub

来源：https://stackoverflow.com/questions/20252224/most-efficient-way-to-add-cell-values-across-congruent-ranges-in-vba

标签

excel

vba

excel-vba