Question

我正在尝试构建一个计算多个sumif的宏，在不同的工作表上查找条件。这是我到目前为止的代码：

Sub SumPerYear()

Dim NoClients As Long
NoClients = Worksheets("Temp").Range("A2").End(xlDown).Row - 1

Sheets("Temp").Activate

For i = 2 To NoClients + 1

    'Fill 2015 € in column E
    Cells(i, 5).Value2 = Application.SumIfs(Worksheets("Q ALL").Range("I:I"), _
        Worksheets("Q ALL").Range("A:A"), 2015, _
        Worksheets("Q ALL").Range("D:D"), Worksheets("Temp").Range("A" & i).Value2, _
        Worksheets("Q ALL").Range("C:C"), True)

    'Fill 2015 # in column F
    Cells(i, 6).Value2 = Application.CountIfs( _
        Worksheets("Q ALL").Range("A:A"), 2015, _
        Worksheets("Q ALL").Range("D:D"), Worksheets("Temp").Range("A" & i).Value2, _
        Worksheets("Q ALL").Range("C:C"), True)

    'Fill 2016 € in column G
    Cells(i, 7).Value2 = Application.SumIfs(Worksheets("Q ALL").Range("I:I"), _
        Worksheets("Q ALL").Range("A:A"), 2016, _
        Worksheets("Q ALL").Range("D:D"), Worksheets("Temp").Range("A" & i).Value2, _
        Worksheets("Q ALL").Range("C:C"), True)

    'Fill 2016 # in column H
    Cells(i, 8).Value2 = Application.CountIfs( _
        Worksheets("Q ALL").Range("A:A"), 2016, _
        Worksheets("Q ALL").Range("D:D"), Worksheets("Temp").Range("A" & i).Value2, _
        Worksheets("Q ALL").Range("C:C"), True)

    'Fill 2017 € in column I
    Cells(i, 9).Value2 = Application.SumIfs(Worksheets("Q ALL").Range("I:I"), _
        Worksheets("Q ALL").Range("A:A"), 2017, _
        Worksheets("Q ALL").Range("D:D"), Worksheets("Temp").Range("A" & i).Value2, _
        Worksheets("Q ALL").Range("C:C"), True)

    'Fill 2017 # in column J
    Cells(i, 10).Value2 = Application.CountIfs( _
        Worksheets("Q ALL").Range("A:A"), 2017, _
        Worksheets("Q ALL").Range("D:D"), Worksheets("Temp").Range("A" & i).Value2, _
        Worksheets("Q ALL").Range("C:C"), True)

    'Fill Tot € in column K
    Cells(i, 11).Value2 = Cells(i, 5) + Cells(i, 7) + Cells(i, 9)

    'Fill Tot # in column L
    Cells(i, 12).Value2 = Cells(i, 6) + Cells(i, 8) + Cells(i, 10)

Next i

End Sub

此代码有效，但由于有数千条记录，因此需要很长时间才能完成。有没有办法让这更有效/更快？

感谢您的投入！

Answer 1

不幸的是，Application方法在大数量的单元格上工作得太慢，所以你应该编写一些代码，这些代码并不像你那么简单。主要想法在这里：

Dim arrA as Variant 'change Variant to your type
Dim arrCD as Variant
Dim arr as Variant
Dim i as long
Dim k as integer
Dim NoClients As Long
NoClients = Worksheets("Temp").Range("A2").End(xlDown).Row - 1

'assign Ranges to arrays
'we can't assign non-contiguous range, so we create two arrays
arrA = Range("A:A")
arrCD = Range("C:D")
ReDim arr(UBound(arrA), 3)
ReDim outArr(NoClients, 5 to 10)
'loop and fill third merged array
For i = 1 To UBound(arrA)
    arr(i, 0) = arrA(i, 1)
    arr(i, 1) = arrCD(i, 1)
    arr(i, 2) = arrCD(i, 2)
Next i

'the rest of code You just loop through
For k = 2 To NoClients + 1 'get client
    For i = 1 To UBound(arr) 'count summuries for him
        if (arr(i,0) = 2016) and (arr(i,1) = true) and (arr(i,2) = _
            Worksheets("Temp").Range("A" & k).Value2) then
            'sumifs replacement
            outArr(k, 5) = outArr(k, 5)  + Worksheets("Q ALL").Cells(1+i, "I").Value2
            'countifs replacement
            outArr(k, 6) = outArr(k, 6) + 1 
        end if
    Next i
Next k

Worksheets("Temp").Range("A2").Value2 = outArr 'prints array on sheet with top left corner at A2

VBA - for循环中的sumifs - 是否有更有效的方法？

1 个答案: