Une sommeprod en vba

[Florian53]

Bonsoir à tous,

Je voudrais faire l'addition d'une valeur en fonction de 3 critères:
Le tableau est énorme (+200000lignes) donc je souhaiterais une solution par VBA, pour diminuer le temps de latence de la macro.

Je dispose d'une base de donnée "BDD" et d'une feuille "Données" ou je voudrais que les résultats s'affichent.

Je dispose de 3 critères:

- 2 sont fixes et sont rentrées en "Dur" dans la feuille "Données"
-1 et dynamique, c'est une liste qui peut avoir 2 comme 200 lignes, je voudrais que la macro scrute chaque lignes de la BDD afin de voir si les lignes concordent avec les critères et additionner toutes les valeurs des lignes ou les critères correspondent. Je cherche à rentrer cette valeur dans la cellule de droite de "Crit3".

Voici le code que j'ai commencé à faire, mais celui ne convient pas du tout car non seulement il ne garde pas en mémoire les anciennes valeurs afin de les additionner avec les nouvelles, mais en plus il fait défiler les lignes du tableau BDD avec les lignes du crit3.

Je n'arrive pas à résoudre ce problème:

Sub family()

Dim tabBDD
Dim wsBDD As Object
Dim wsResult As Object

Dim crit1, crit2, crit3
Dim cptBDD
Dim i As Integer



    Set wsBDD = Worksheets("BDD") 'Base de données
    Set wsResult = Worksheets("données") ' Feuille résultat final

   
    With wsBDD
        tabBDD = Range(.Cells(3, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 30)) ' Définition du tableau
    End With
   
    With wsResult
    derlign = Cells(Cells.Columns.Count, 7).End(xlToLeft).Offset(0, 0).Row 'Dernière ligne de la liste du critére 3 à scrutée dans la BDD
   
    For cptBDD = 1 To UBound(tabBDD, 1) 'Scrutation du tableau BDD
    For i = 2 To derlign ' Liste du critère 3
   
        crit1 = .Cells(1, 6) ' Critére 1
        crit2 = .Cells(2, 6) 'Critère 2
        crit3 = .Cells(i, 7) ' Critère 3
   

            If (tabBDD(cptBDD, 23) = crit1) And (tabBDD(cptBDD, 1) = crit2) And (tabBDD(cptBDD, 24) = crit3) Then
                Cells(i, 8) = Cells(i, 8) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20)
                End If
        Next i
               
         Next
   
        
           
    End With
                      
       
   
    Set wsBDD = Nothing
    Set wsResult = Nothing
   
   

End Sub

Est ce que vous pouvez m'aider?
Si vous voulez un fichier pour une meilleur compréhension, je vais pouvoir le transmettre demain.

Merci

 

[Florian53]

Voici le fichier, pour une meilleur compréhension

Depuis hie soir j'ai essayé ce code qui ne fonctionne pas non plus

Sub family()

Sub family()

Dim sWkBDD As Worksheet
Dim sWkASS As Worksheet
Dim tabBDD()
Dim Som(19) As Long, iCol As Long
Dim crit1, crit2, crit3
'
Set sWkBDD = Worksheets("BDD")
Set sWkASS = Worksheets("Données")
'
With sWkBDD
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    tabBDD = .Range("A3:AE" & iRow).Value
End With

With sWkASS
    crit1 = .Cells(1, 6)
   crit2 = .Cells(2, 6)
   '
   For iCol = 2 To .Cells(Rows.Count, 7).End(xlDown).Row
        crit3 = .Cells(iCol,7 )
       '
       For y = 1 To UBound(tabBDD, 1)
            Select Case tabBDD(y, 1) & tabBDD(y, 31)
                Case Is = crit2 & crit1 & crit3
                    x = 1
         
            End Select
            Som(1 + (x * 1)) = Som(1 + (x * 1)) + tabBDD(y, 15) + tabBDD(y, 16) + tabBDD(y, 18) + tabBDD(y, 20)
       Next
        '
       For x = 2 To .Cells(Rows.Count, 7).End(xlDown).Row
                    .Cells(x + 1, iCol) = Som(x)
            End
        Next
    Next
End With
End Sub

 

[Iznogood1]

Bonjour,
Peux-tu préciser ta demande :
où sont saisis les critères ?
qu'appelles-tu "additionner toutes les valeurs des lignes" ; est-ce faire le total des valeurs de la ligne ?

 

[thebenoit59]

Bonjour Florian.
Bonjour le forum.

Voilà une première proposition :

Option Explicit

Sub Family()
'Déclaration des variables.
Dim arrBDD()
Dim crit1%, crit2$, crit3()
Dim shBDD As Worksheet, shDonn As Worksheet
Dim dico As Object
Dim i&

'Enregistrement des objets.
Set shBDD = ThisWorkbook.Sheets("BDD")
Set shDonn = ThisWorkbook.Sheets("Données")
Set dico = CreateObject("Scripting.Dictionary")

'Enregistrement du tableau arrBDD.
With shBDD
    i = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    arrBDD = .Range(.Cells(2, "A"), .Cells(i, "X")).Value
End With

'Enregistrement des critères.
With shDonn
    crit1 = .[F1].Value
    crit2 = .[F2].Value
    i = 2
    Do While .Cells(i, "G").Value <> ""
        dico(.Cells(i, "G").Value) = 0
        i = i + 1
    Loop
End With

'Boucle du tableau virtuel.
For i = LBound(arrBDD) + 1 To UBound(arrBDD)
    If arrBDD(i, 1) = crit1 And arrBDD(i, 23) = crit2 And dico.exists(arrBDD(i, 24)) Then
        dico(arrBDD(i, 24)) = dico(arrBDD(i, 24)) + arrBDD(i, 15) + arrBDD(i, 16) + arrBDD(i, 18) + arrBDD(i, 20)
    End If
Next i

'Report des sommes dans la feuille Données.
With shDonn
    i = 2
    Do While .Cells(i, "G").Value <> ""
        .Cells(i, "G").Offset(, 1).Value = dico(.Cells(i, "G").Value)
        i = i + 1
    Loop
End With
End Sub

 

[Florian53]

Merci thebenoit59, ça fonctionne nickel