VBA - forループのsumif - より効率的な方法はありますか？

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

残念なことに、アプリケーションメソッドは大量のセルでは処理が遅すぎますので、コードを書く必要があります。これはあなたのものほど素敵で簡単ではありません。 主なアイデアは、ここでcatchedさ：

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