Utilisation plus rapide de Sumifs ()

Nov 21 2020

J'ai une tâche hebdomadaire où je dois mettre à jour un rapport (actuellement un peu plus de 50 000 lignes) qui augmente d'environ 500 lignes chaque semaine. Une fois les nouvelles données ajoutées manuellement, j'exécute le code ci-dessous pour faire un Sumifs()pour résumer les données.

La structure des données est la suivante: les colonnes A à C sont les colonnes de critères (numérique-alphanumérique), la colonne D a la quantité à additionner (nombres entiers). Les données sont contiguës. Ma macro met la Sumifs()formule dans la colonne E - écrasant ce qu'il y a.

Ma question est la suivante: cette tâche peut-elle être effectuée plus rapidement? Il me faut actuellement un peu plus d'une minute pour exécuter la macro, mais cela s'allonge à mesure que les données augmentent.

Il y a beaucoup de choses sur ce site sur l'utilisation des tableaux pour effectuer des tâches plus rapidement, mais aucun des exemples n'a beaucoup de sens pour moi et je préférerais ne pas les utiliser si possible.

Sub MySumIfs()
Dim LastRow As Long

LastRow = Sheet1.Range("A1").End(xlDown).Row

With Sheet1.Range("E2:E" & LastRow)
    .FormulaR1C1 = "=sumifs(R2C4:R" & LastRow & "C4, R2C1:R" & LastRow & "C1, RC1, R2C2:R" & LastRow & "C2, RC2, R2C3:R" & LastRow & "C3, RC3)"
    .Value = .Value
End With

End Sub

Réponses

2 TimWilliams Nov 21 2020 at 13:33

Voici une autre façon:

EDIT - mis à jour pour ajouter des "averageifs" et "sumifs" à ma version initiale (erronée) de "countifs" ...

Sub SetupDummyData()
    Const NUM As Long = 100001
    Range("A1:E1").Value = Array("A_Header", "B_Header", "C_Header", "Value", "ResultHere")
    Range("A2:A" & NUM).Formula = "=""A#"" & round(RAND()*10,0)"
    Range("B2:B" & NUM).Formula = "=""B#"" & round(RAND()*10,0)"
    Range("C2:C" & NUM).Formula = "=""C#"" & round(RAND()*10,0)"
    Range("D2:D" & NUM).Formula = "=round(RAND()*100,1)"
    
    Range("A2:D" & NUM).Value = Range("A2:D" & NUM).Value
End Sub


Sub Tester()
    
    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(1, 2, 3)  'these columns form the composite key
    valueCol = 4              'column with values (for sum)
    destCol = 5               'destination for calculated values
    
    t = Timer
    
    Set ws = ActiveSheet
    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
1 kevin9999 Nov 21 2020 at 12:00

@ RuthMac77, vous devriez écouter les conseils de chris neilsen et rechercher des solutions possibles pour les tableaux, ou faire une recherche sur Google pour les didacticiels sur les tableaux - il y en a beaucoup.

Cela dit, je répondu à une question très semblable à celui - ci il y a quelques années ici . En utilisant votre description, j'ai répliqué la structure de données telle que vous l'avez décrite avec 50 000 lignes de données. Le tester à l'aide de votre code existant a pris environ 55 secondes.

En utilisant la méthode concaténation / tri / IF décrite ci-dessous, les mêmes données n'ont pris que 1,5 seconde à calculer. Copiez le code dans votre module et dites-moi comment vous allez avec.

Option Explicit
Sub FasterThanSumIfs()
Application.ScreenUpdating = False

Dim LastRow As Long
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

'Step 1: Concatenate the 3 values to a single string then sort by that string
With Sheet1.Range("E2:E" & LastRow)
    .FormulaR1C1 = "=(RC1 & CHAR(32) & RC2 & CHAR(32) & RC3)"
    .Value = .Value
End With
Sheet1.Columns("A:E").Sort Key1:=Sheet1.Range("E2"), Order1:=xlAscending, Header:=xlYes
Sheet1.Sort.SortFields.Clear

'Step 2: calculate the sum range column where the concatenated values are the same
With Sheet1.Range("F2:F" & LastRow)
    .FormulaR1C1 = "=IF(RC5=R[-1]C5,RC4+R[-1]C6,RC4)"
    .Value = .Value
End With

'Step 3: sort by string then by summed values largest to smallest to
'place the largest values at the top of each concatenated values' 'list'
Sheet1.Columns("A:F").Sort Key1:=Range("E2"), Order1:=xlAscending, _
Key2:=Range("F2"), Order2:=xlDescending, Header:=xlYes
Sheet1.Sort.SortFields.Clear

'Step 4: Return the highest value for each concatenated string
With Sheet1.Range("G2:G" & LastRow)
    .FormulaR1C1 = "=IF(RC5=R[-1]C5,R[-1]C7,RC6)"
    .Value = .Value
End With

'Step 5: replace the concatenated string values in column E with
'the Sumifs() values from column G.  Column E now contains the correct Sumifs()
'values as if a Sumifs() formula had been used - only much quicker!

Sheet1.Range("G2:G" & LastRow).Copy Sheet1.Range("E2")
Sheet1.Range("F:G").Clear

Application.ScreenUpdating = True
End Sub