Sous totaux avec criteres multiples dans un tableau vba (array)

T

taupivin

XLDnaute Junior
Bonjour tous le monde,

je sollicite votre aide car je me casse les dents depuis quelques jours sur un probleme dont l'enonce peut paraitre simple, mais qui est pour moi, complique. Le voici :

Il s'agit de l'etude de mouvements de stock.

Pour chaque article colonne A :
Pour chaque code mouvement (Movement Type --> colonne E) :
Faire la somme des Quantites (Qty in Un. of Entry --> colonne L)

A la condition suivante (c'est ici que je bloque) :

Si la date du dernier mouvements 901 > date du dernier mouvements 101 Alors
Ce mouvement doit etre considere comme un mouvement 902

Code: 
Sub creationTableAjujustement()
'on initialise la feuille source
'on initialise la table source
Set f = ThisWorkbook.Sheets("DataBase")
TblBD = f.Range("a2:s" & f.[s200000].End(xlUp).Row).Value
colCrit1 = 1: colCrit2 = 5: colOper = 12
'on initialise la feuille resultat
Set Result = ThisWorkbook.Worksheets("Adjustments").Range("a2")
'on cree les dictionnaires index pour rapidité
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
'on cree les tableaux
Dim TblTot(): ReDim TblTot(1 To UBound(TblBD), 1 To 3)
Dim TblTotLig(): ReDim TblTotLig(1 To UBound(TblBD))
Dim TblTotCol(): ReDim TblTotCol(1 To 3)
'on fait les calculs pour chaque item
    For i = LBound(TblBD) To UBound(TblBD)
        'definition des clefs d'entres
        clé1 = TblBD(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
        clé2 = TblBD(i, colCrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
        'Sommes
        TblTot(lig, col) = TblTot(lig, col) + TblBD(i, colOper)
        TblTotCol(col) = TblTotCol(col) + TblBD(i, colOper)
    Next i
'on affiche les resultats
Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys)   ' titre lignes
Result.Offset(, 1).Resize(1, d2.Count) = d2.keys                        ' titres colonnes
Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot                 ' stat 2D
Result.Offset(-1, 1).Resize(, d2.Count) = TblTotCol                     ' somme pour chaque colonne
End Sub

J'espere que je suis assez clair.
Merci par avance a toutes les personnes qui prendront de leurs temps pour m'aider.

Ps : vous trouverez le fichier en PJ

Bien cordialement.

Vincent
 

Pièces jointes

  • Test somme .xlsm
    845.2 KB · Affichages: 34
Trier par date Trier par votes
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

Code: 
Sub Stat2DTab()
  Set f = Sheets("DataBase")
  tblbd = f.Range("A2:L" & f.[A65000].End(xlUp).Row).Value ' Array pour rapidité
  colCrit1 = 1: colcrit2 = 5: colOper = 12
  Set Result = Sheets("adjustments").Range("A1")     ' Adresse résultat
  Set d1 = CreateObject("Scripting.Dictionary") ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim TblTot(): ReDim TblTot(1 To UBound(tblbd), 1 To UBound(tblbd, 2))
  '--- traitement 101/901
  Mx101 = 0: Mx901 = 0: p901 = 0
  For i = LBound(tblbd) To UBound(tblbd)
       If tblbd(i, colcrit2) = "101" Then
          If tblbd(i, 9) > Mx101 Then Mx101 = tblbd(i, 9)
       End If
       If tblbd(i, colcrit2) = "901" Then
          If tblbd(i, 9) > Mx901 Then Mx901 = tblbd(i, 9): p901 = i
       End If
  Next i
  If Mx901 > Mx101 Then tblbd(p901, colcrit2) = "902"
  '----
  Dim TblTotLig(): ReDim TblTotLig(1 To UBound(tblbd))
  Dim TblTotCol(): ReDim TblTotCol(1 To UBound(tblbd, 2))
  For i = LBound(tblbd) To UBound(tblbd)
    clé1 = tblbd(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
    clé2 = tblbd(i, colcrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
    TblTot(lig, col) = TblTot(lig, col) + tblbd(i, colOper)
    TblTotLig(lig) = TblTotLig(lig) + tblbd(i, colOper)
    TblTotCol(col) = TblTotCol(col) + tblbd(i, colOper)
  Next i
  Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titre lignes
  Result.Offset(, 1).Resize(1, d2.Count) = d2.keys ' titres colonnes
  Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot ' stat 2D
  Result.Offset(d1.Count + 1, 1).Resize(, d2.Count) = TblTotCol ' totaux colonnes
  Result.Offset(1, d2.Count + 1).Resize(d1.Count) = Application.Transpose(TblTotLig) ' totaux lignes
End Sub


Boisgontier
http://boisgontierjacques.free.fr
 

Pièces jointes

  • Copie de Test somme .xlsm
    856.8 KB · Affichages: 37
Dernière édition:
Vote positif 0 Vote négatif
T

taupivin

XLDnaute Junior
taupivin à dit:
Bonjour tous le monde,

je sollicite votre aide car je me casse les dents depuis quelques jours sur un probleme dont l'enonce peut paraitre simple, mais qui est pour moi, complique. Le voici :

Il s'agit de l'etude de mouvements de stock.

Pour chaque article colonne A :
Pour chaque code mouvement (Movement Type --> colonne E) :
Faire la somme des Quantites (Qty in Un. of Entry --> colonne L)

A la condition suivante (c'est ici que je bloque) :

Si la date du dernier mouvements 901 > date du dernier mouvements 101 Alors
Ce mouvement doit etre considere comme un mouvement 902

Code: 
Sub creationTableAjujustement()
'on initialise la feuille source
'on initialise la table source
Set f = ThisWorkbook.Sheets("DataBase")
TblBD = f.Range("a2:s" & f.[s200000].End(xlUp).Row).Value
colCrit1 = 1: colCrit2 = 5: colOper = 12
'on initialise la feuille resultat
Set Result = ThisWorkbook.Worksheets("Adjustments").Range("a2")
'on cree les dictionnaires index pour rapidité
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
'on cree les tableaux
Dim TblTot(): ReDim TblTot(1 To UBound(TblBD), 1 To 3)
Dim TblTotLig(): ReDim TblTotLig(1 To UBound(TblBD))
Dim TblTotCol(): ReDim TblTotCol(1 To 3)
'on fait les calculs pour chaque item
    For i = LBound(TblBD) To UBound(TblBD)
        'definition des clefs d'entres
        clé1 = TblBD(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
        clé2 = TblBD(i, colCrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
        'Sommes
        TblTot(lig, col) = TblTot(lig, col) + TblBD(i, colOper)
        TblTotCol(col) = TblTotCol(col) + TblBD(i, colOper)
    Next i
'on affiche les resultats
Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys)   ' titre lignes
Result.Offset(, 1).Resize(1, d2.Count) = d2.keys                        ' titres colonnes
Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot                 ' stat 2D
Result.Offset(-1, 1).Resize(, d2.Count) = TblTotCol                     ' somme pour chaque colonne
End Sub

J'espere que je suis assez clair.
Merci par avance a toutes les personnes qui prendront de leurs temps pour m'aider.

Ps : vous trouverez le fichier en PJ

Bien cordialement.

Vincent
Cliquez pour agrandir...
BOISGONTIER à dit:
Bonjour,

cf PJ

Boisgontier
http://boisgontierjacques.free.fr
Cliquez pour agrandir...
BOISGONTIER à dit:
Bonjour,

Code: 
Sub Stat2DTab()
  Set f = Sheets("DataBase")
  tblbd = f.Range("A2:L" & f.[A65000].End(xlUp).Row).Value ' Array pour rapidité
  colCrit1 = 1: colcrit2 = 5: colOper = 12
  Set Result = Sheets("adjustments").Range("A1")     ' Adresse résultat
  Set d1 = CreateObject("Scripting.Dictionary") ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim TblTot(): ReDim TblTot(1 To UBound(tblbd), 1 To UBound(tblbd, 2))
  '--- traitement 101/901
  Mx101 = 0: Mx901 = 0: p901 = 0
  For i = LBound(tblbd) To UBound(tblbd)
       If tblbd(i, colcrit2) = "101" Then
          If tblbd(i, 9) > Mx101 Then Mx101 = tblbd(i, 9)
       End If
       If tblbd(i, colcrit2) = "901" Then
          If tblbd(i, 9) > Mx901 Then Mx901 = tblbd(i, 9): p901 = i
       End If
  Next i
  If Mx901 > Mx101 Then tblbd(p901, colcrit2) = "902"
  '----
  Dim TblTotLig(): ReDim TblTotLig(1 To UBound(tblbd))
  Dim TblTotCol(): ReDim TblTotCol(1 To UBound(tblbd, 2))
  For i = LBound(tblbd) To UBound(tblbd)
    clé1 = tblbd(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
    clé2 = tblbd(i, colcrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
    TblTot(lig, col) = TblTot(lig, col) + tblbd(i, colOper)
    TblTotLig(lig) = TblTotLig(lig) + tblbd(i, colOper)
    TblTotCol(col) = TblTotCol(col) + tblbd(i, colOper)
  Next i
  Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titre lignes
  Result.Offset(, 1).Resize(1, d2.Count) = d2.keys ' titres colonnes
  Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot ' stat 2D
  Result.Offset(d1.Count + 1, 1).Resize(, d2.Count) = TblTotCol ' totaux colonnes
  Result.Offset(1, d2.Count + 1).Resize(d1.Count) = Application.Transpose(TblTotLig) ' totaux lignes
End Sub


Boisgontier
http://boisgontierjacques.free.fr
Cliquez pour agrandir...



Bonjour Jacques,

Tout d'abord merci beaucoup pour votre temps.
Je pense que je me suis mal exprime lors de l'enonce initial.
En fait, il faudrait que le traitement 101/901 se fasse pour chaque article colonne A et non pas une fois pour l'ensemble des donnees. ^^'
(cf fichier joint)

Merci encore pour votre aide.
 

Pièces jointes

  • Test somme V2.xlsm
    873.4 KB · Affichages: 26
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

Code: 
Sub Stat2DTab()
  Set f = Sheets("DataBase")
  tblBD = f.Range("A2:L" & f.[A65000].End(xlUp).Row).Value ' Array pour rapidité
  colCrit1 = 1: colcrit2 = 5: colOper = 12
  Set Result = Sheets("adjustments").Range("A1")     ' Adresse résultat
  Set d1 = CreateObject("Scripting.Dictionary") ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim TblTot(): ReDim TblTot(1 To UBound(tblBD), 1 To UBound(tblBD, 2))
  '--- traitement 101/901
  For i = LBound(tblBD) To UBound(tblBD)
   d1(tblBD(i, colCrit1)) = ""
  Next i
  For Each c In d1.keys
    Mx101 = 0: Mx901 = 0: p901 = 0
    For i = LBound(tblBD) To UBound(tblBD)
       If tblBD(i, colcrit2) = "101" Then
          If tblBD(i, colCrit1) = c Then If tblBD(i, 9) > Mx101 Then Mx101 = tblBD(i, 9)
       End If
       If tblBD(i, colcrit2) = "901" Then
          If tblBD(i, colCrit1) = c Then If tblBD(i, 9) > Mx901 Then Mx901 = tblBD(i, 9): p901 = i
       End If
    Next i
     If Mx901 > Mx101 Then tblBD(p901, colcrit2) = "902"
   Next c
  '----
  Dim TblTotLig(): ReDim TblTotLig(1 To UBound(tblBD))
  Dim TblTotCol(): ReDim TblTotCol(1 To UBound(tblBD, 2))
  d1.RemoveAll
  For i = LBound(tblBD) To UBound(tblBD)
    clé1 = tblBD(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
    clé2 = tblBD(i, colcrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
    TblTot(lig, col) = TblTot(lig, col) + tblBD(i, colOper)
    TblTotLig(lig) = TblTotLig(lig) + tblBD(i, colOper)
    TblTotCol(col) = TblTotCol(col) + tblBD(i, colOper)
  Next i
  Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titre lignes
  Result.Offset(, 1).Resize(1, d2.Count) = d2.keys ' titres colonnes
  Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot ' stat 2D
  Result.Offset(d1.Count + 1, 1).Resize(, d2.Count) = TblTotCol ' totaux colonnes
  Result.Offset(1, d2.Count + 1).Resize(d1.Count) = Application.Transpose(TblTotLig) ' totaux lignes
End Sub

Boisgontier
 

Pièces jointes

  • Copie de Test somme V2-2.xlsm
    858.2 KB · Affichages: 37
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

O
  • Résolu(e)
XL 2019 Moyenne de valeurs par date à partir d'un tableau
Réponses
4
Affichages
909
Olocsob
O
T
  • Question
[Resolu] erreur : Subscript out of range
Réponses
7
Affichages
1 K
taupivin
T
P
  • Question
Microsoft 365 Comparaison de tableaux !
Réponses
1
Affichages
2 K
Patrosso
P
S
  • Question
Autres code VBA affichage de données
Réponses
1
Affichages
793
fanch55
fanch55
S
  • Question
Autres problème code vba avec le bouton supprimer et ajouter
Réponses
2
Affichages
1 K
sylvanu
sylvanu
C
  • Question
XL 2016 Collection d'objets personnalisés avec propriété tableau dans VBA excel
2
Réponses
19
Affichages
5 K
Dranreb
Dranreb
cathodique
  • Question
XL 2010 Tri Croissant Array 2D sur 2 colonnes
Réponses
10
Affichages
1 K
cathodique
cathodique
E
  • Question
Problème avec BDTableau et sélection feuille
Réponses
3
Affichages
895
erics83
E
L
  • Question
XL 2013 Copier les doublons dans un autre classeur
Réponses
9
Affichages
1 K
louloubru
L
B
  • Question
XL 2013 Utilisation de tableaux pour faire un graphique
Réponses
0
Affichages
691
babalouche
B

Membres actuellement en ligne

3 membres et 45 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 636
Messages
2 111 464
Membres
111 151
dernier inscrit
KARIMTAPSO