Calcul tableau VBA

F

Florian53

XLDnaute Impliqué
Bonsoir à tous,

Je cherche a réaliser une macro avec 2 tableau afin d'optimiser la vitesse de calcul, mais mes faibles compétences en vba m'arrête donc je vous demande de l'aide.

Je dispose :

- D'une feuille nommée "BDD" qui est remplie avec environ 200 000 lignes sur 30 colonnes

- D'une autre feuille ou je souhaite recueillir les résultats des calculs de la macro ci dessous:

VB: 
Private Sub Somme12mgFamilly()
Dim tabBDD()
Dim TabSom()
Dim wsBDD As Object
Dim wsResult As Object
Dim crit1, crit2, crit3, crit4
Dim cptBDD
Dim i As Integer

        Set wsBDD = Worksheets("BDD") ' Définition de wsBDD
        Set wsResult = Worksheets("Familly & Country") ' Définition de wsResult
       
With wsBDD
    tabBDD = Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 30)) ' Définition du tableau de BDD
End With

With wsResult

derlig = Cells(Rows.Count, 1).End(xlUp).Offset(0, 0).Row  ' Dernier ligne de la feuille de travail
dercol = Cells(1, Cells.Columns.Count).End(xlToLeft).Offset(0, 0).Column ' Derniere colonne de la feuille de travail

TabSom = Range(.Cells(2, 3), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 52)) ' Définition du tableau de la feuille de travail
        For i = 2 To derlig Step 4
       
            For j = 4 To dercol

         crit1 = .Cells(i, 1)  'Pays
         crit2 = "2016"  '2016
         crit3 = "Octobre 2017" 'Octobre 2017
         crit4 = "Octobre 2016" 'Octobre 2016
         crit5 = .Cells(1, j) 'Famille
        

   
                 For cptBDD = 1 To UBound(tabBDD, 1)
                
                 '***************************************************************************************************** Total
                
                         If (tabBDD(cptBDD, 30) = crit1) And (tabBDD(cptBDD, 1) = crit2) Then
                            TabSom(i) = TabSom(i) + tabBDD(cptBDD, 11) 'Quantité 2016
                            TabSom(1 + i) = TabSom(1 + i) + tabBDD(cptBDD, 12) 'Vente 2016
                            TabSom(2 + i) = TabSom(2 + i) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'Réparation 2016
               
                         ElseIf (tabBDD(cptBDD, 30) = crit1) And (tabBDD(cptBDD, 1) = crit3) Then
                            TabSom(3 + i) = TabSom(3 + i) + tabBDD(cptBDD, 11) 'Quantité Octobre 2017
                            TabSom(4 + i) = TabSom(4 + i) + tabBDD(cptBDD, 12) 'Vente Octobre 2017
                            TabSom(5 + i) = TabSom(5 + i) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'Réparation Octobre 2017
               
                         ElseIf (tabBDD(cptBDD, 30) = crit1) And (tabBDD(cptBDD, 1) = crit4) Then
                            TabSom(6 + i) = TabSom(6 + i) + tabBDD(cptBDD, 11) 'Quantité Octobre 2016
                            TabSom(7 + i) = TabSom(7 + i) + tabBDD(cptBDD, 12) 'Vente Octobre 2016
                            TabSom(8 + i) = TabSom(8 + i) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'Réparation Octobre 2016
                '********************************************************************************************************** Fin Total
               
               
                '******************************************************************************************************** Total par famille
                         ElseIf (tabBDD(cptBDD, 1) = crit2) And (tabBDD(cptBDD, 30) = crit1) And (tabBDD(cptBDD, 24) = crit5) Then
                            TabSom(9 + i) = TabSom(9 + i) + tabBDD(cptBDD, 11) 'Quantité 2016 avec Familly
                            TabSom(10 + i) = TabSom(10 + i) + tabBDD(cptBDD, 12) 'Vente 2016 avec Familly
                            TabSom(11 + i) = TabSom(11 + i) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'Réparation 2016 avec famille
               
                         ElseIf (tabBDD(cptBDD, 1) = crit3) And (tabBDD(cptBDD, 30) = crit1) And (tabBDD(cptBDD, 24) = crit5) Then
                            TabSom(12 + i) = TabSom(12 + i) + tabBDD(cptBDD, 11) 'Quantité Octobre 2017 avec Familly
                            TabSom(13 + i) = TabSom(13 + i) + tabBDD(cptBDD, 12) 'Vente Octobre 2017 avec Familly
                            TabSom(14 + i) = TabSom(14 + i) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'Réparation Octobre 2017 avec famille
               
                        ElseIf (tabBDD(cptBDD, 1) = crit4) And (tabBDD(cptBDD, 30) = crit1) And (tabBDD(cptBDD, 24) = crit5) Then
                            TabSom(15 + i) = TabSom(15 + i) + tabBDD(cptBDD, 11) 'Quantité Octobre 2016 avec Familly
                            TabSom(16 + i) = TabSom(16 + i) + tabBDD(cptBDD, 12) 'Vente Octobre 2016 avec Familly
                            TabSom(17 + i) = TabSom(17 + i) + tabBDD(cptBDD, 14) + tabBDD(cptBDD, 15) + tabBDD(cptBDD, 16) + tabBDD(cptBDD, 18) + tabBDD(cptBDD, 20) 'Réparation Octobre 2016 avec famille
                        End If
                       
                '*********************************************************************************************************** Fin Total par famille
        Next
                              
        Next
       
        Next

    For i = 2 To derlig Step 4
   
        For j = 4 To dercol
       
         .Cells(i, j) = TabSom(i) + TabSom(3 + i) - TabSom(6 + i) 'Quantités
         .Cells(i + 1, j) = (TabSom(1 + i) + TabSom(4 + i) - TabSom(7 + i)) 'Vente
         .Cells(i + 2, j) = (TabSom(2 + i) + TabSom(5 + i) - TabSom(8 + i)) * -1 'Réparation
                  If (TabSom(1 + i) + TabSom(4 + i) - TabSom(7 + i)) = 0 Then
                     .Cells(3 + i, j) = 0
                     Else
                    .Cells(3 + i, j) = (TabSom(2 + i) + TabSom(5 + i) - TabSom(8 + i)) * -1 / (TabSom(1 + i) + TabSom(4 + i) - TabSom(7 + i)) '%E/R
                 End If
       
    Next
    Next
   
End With
   
        Set wsBDD = Nothing
        Set wsResult = Nothing
End Sub

Je souhaiterais avoir le totaux général par pays, puis les totaux par famille.
J'ai commencé cette macro, mais je pense que mon tableau "TabSom" n'est pas bon et je n'arrive à différencier les totaux généraux des totaux par famille.

Je vous transmets un fichier exemple en pièce jointe

Merci à vous pour votre aide
 

Pièces jointes

  • Test.xlsm
    157.7 KB · Affichages: 21
Trier par date Trier par votes
F

Florian53

XLDnaute Impliqué
J'ai réalisé une macro "ordinaire" qui fonctionne mais celle ci prends environ 3minutes, à priori si je passerais avec des tableaux le code prendrait beaucoup moins de temps.
Donc j'ai essayé de réaliser le code (1er post), mais mes compétences actuelles en VBA me limite.

Le fonctionnement attendu par la macro est :

En colonne "C" de la feuille "Familly & Country" --> Les totaux par pays en fonction des 3 critères :

- Quantité : Colonne "K"
- Ventes : Colonne "L"
- Réparation : Addition des Colonnes "N, O, P, R, T"
- % % Ventes / Réparation : Divison de la colonne "L" par Colonnes "N, O, P, R, T"

* La colonne "C" est juste l'addition de la colonne "D" à Dercol .

Pour les colonnes de "D" à dercol de la feuille "Familly & Country" --> Les totaux par pays et par familles en fonction des 3 mêmes critères ci dessus.

Pouvez vous me guider sur le fonctionnement des tableaux afin de modifier la macro ?

Merci à vous
 
Vote positif 0 Vote négatif
F

Florian53

XLDnaute Impliqué
Bonjour et merci de ta réponse Dranreb ,

Je dispose d'une macro qui me liste au préalable les familles dans l'ordre croissant en fonction des réparations pour le top1 des pays .

Donc il faudrait juste que la macro respecte l'ordre des cellules (1,j) .
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Zut, je l'ai déjà écrit en utilisant la fonction DicInvent de la fourniture GigIdx…
Mais on pourrait facilement remplir le Dictionary d'après les titres. Mais je laisserai comme c'est pour le moment…
Ce ne serait pas "% Réparation / Ventes" plutôt que "% Ventes / Réparation" ?
 

Pièces jointes

  • GigIdx.xlsm
    67.9 KB · Affichages: 16
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Le premier jet de ma procédure, avec GigIdx en référence dans le projet :
VB: 
Option Explicit

Private Sub Somme12mgFamilly()
Dim Dic As New Dictionary, ColGig As Collection, T(), Pays As SsGr, Article As SsGr, _
   L&, C&, S As Double
Set Dic = GigIdx.DicInvent(Worksheets("BDD").[A2:AD2], 24, ColDép:=4)
Set ColGig = Gigogne(Null, 30, 24)
ReDim T(1 To 1 + ColGig.Count * 4, 1 To 4)
GigIdx.VerserTitres T, Dic
L = 1: T(1, 3) = "Total"
Worksheets("Familly & Country").[A18].Resize(UBound(T, 1), UBound(T, 2)).Value = T
For Each Pays In ColGig
   L = L + 1
   T(L, 1) = Pays.Id: T(L, 2) = "Quantité": T(L + 1, 2) = "Ventes"
   T(L + 2, 2) = "Réparation": T(L + 3, 2) = "% Ventes / Réparation"
   For Each Article In Pays.Co
      C = Dic(Article.Id)
      S = Article.somme(11): T(L, C) = T(L, C) + S: T(L, 3) = T(L, 3) + S
      S = Article.somme(12): T(L + 1, C) = T(L + 1, C) + S: T(L + 1, 3) = T(L + 1, 3) + S
      S = Article.somme(14) + Article.somme(15) + Article.somme(16) + Article.somme(18) + Article.somme(20)
      T(L + 2, C) = T(L + 2, C) + S: T(L + 2, 3) = T(L + 2, 3) + S
      Next Article
   For C = 3 To UBound(T, 2)
      If T(L + 1, C) <> 0 And T(L + 2, C) <> 0 Then T(L + 3, C) = T(L + 2, C) / T(L + 1, C)
      Next C
   L = L + 3: Next Pays
With Worksheets("Familly & Country")
   .Cells.ClearContents
   .[A1].Resize(UBound(T, 1), UBound(T, 2)).Value = T
   End With
End Sub
 
Vote positif 0 Vote négatif
F

Florian53

XLDnaute Impliqué
Super, merci à toi.

Je n'ai pas encore essayé ta solution, car je me pose une question, j'aimerais que mon fichier soit utilisable par n'importe qui, est ce que le complément de GigIdx sera à installer sur tout les postes susceptible d'ouvrir le fichier ?
 
Vote positif 0 Vote négatif
F

Florian53

XLDnaute Impliqué
Le fichier que je souhaite réaliser, sera certainement utilisé par des personnes que je ne connais pas dans mon groupe, je ne pourrais pas imposer à ces personnes une installation de complément sur leur poste.

Existe -il une solution ou l'opérateur aura juste a activer les macros pour pouvoir réaliser les calculs ?
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Je vous ai indiqué une possibilité au poste précédent. Vous ne m'avez pas répondu au sujet de l'hypothèse qu'il l'ouvrent depuis un dossier réseau, mais je suppose que oui, sinon vous auriez bien à installer le classeur chez les utilisateurs, alors vous pourriez bien en profiter pour installer aussi le complément.
Si vous installez le complément dans le même dossier que celui ou est le classeur, ça devrait aller, non ?
À tout hasard je joins quand même le classeur équipé des modules de service nécessaires. Ne perdez pas pour autant le GigIdx.xlsm parce que c'est le seule à contenir la feuille d'aide à l'utilisation.
 

Pièces jointes

  • GigogneFlorian53.xlsm
    189.8 KB · Affichages: 20
Vote positif 0 Vote négatif
F

Florian53

XLDnaute Impliqué
Bonjour Dranreb,

Effectivement le fichier sera sur un réseau, j'ai testé votre fichier joint sur ma base de données. Vitesse de calcul incroyable :):).

Mais en voyant les résultats, je me rends comte que ma demande n'était pas complète.
Je souhaiterais avoir un classement dans l'ordre décroissant des pays en fonction de la valeur des réparations.

Et par la suite classé les familles toujours en décroissant par rapport au réparation par rapport au TOP1 des pays ( "A2").

Est ce possible d'avoir aussi les critères accessible comme dans mon 1er post ?

VB: 
[code=VB]crit1 = .Cells(i, 1)  'Pays
         crit2 = "2016"  '2016
         crit3 = "Octobre 2017" 'Octobre 2017
         crit4 = "Octobre 2016" 'Octobre 2016
         crit5 = .Cells(1, j) 'Famille
[/code]

La formule attendu est : "2016 + Octobre 2017 - Ocotbre2016" mais j'ai indiqué ces critères pour l'exemple, mais les vrais critères seront sous la forme:

crit2 = "Réel ...." ' car l'année peut varier
crit3 = "AAA BBB 010.2017" ' le mois et l'année peut varier
crit4 = "AAA BBB 010.2016" ' le mois et l'année peut varier

Le but est de calculer un 12 mois glissant en fonction de la demande et de la BDD disponible.
Je ne sais pas si le code est modifiable dans ce sens ?
Encore merci à toi pour l'aide que tu m'apportes
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour.
Non, désolé je ne comprends rien.
Pour 3 pays il me semble que l'ordre importe peu. On voit assez vite où est le total des réparations les plus élevées.
Cela dit, Gigogne peut accepter des colonnes de critères à présenter en ordre décroissant. Il suffit de mettre un signe moins devant le numéro de la colonne.
 
Vote positif 0 Vote négatif
F

Florian53

XLDnaute Impliqué
La BDD fournit dans le fichier est réduit considérablement, ma BDD que je dispose à 55 pays et environ 50 familles soit plus 100 000 lignes. c'est pour ça que je souhaiterais avoir un classement dans mon code " Ordinaire" je dispose de 3 macro :

- 1 qui me liste les pays par ordre décroissant en fonction de la valeur des réparations
- 1 qui me liste les familles par ordre décroissant en fonction de la valeur des réparations pour le Top1 des familles

- 1 qui me remplit intégralement le tableau en fonction de la colonne "A2:A & derlign" et "C1 à C & dercol"
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Au lieu de la colonne contenant le pays il faut donner comme critère de regroupement à Gigogne une colonne contenant le numéro d'ordre du pays dans le classement souhaité, et, pour restituer quand même le nom du pays, au lieu de T(L,1) = Pays.Id mettre T(L, 1) = Pays.Co(1).Co(1)(30)
 
Vote positif 0 Vote négatif
F

Florian53

XLDnaute Impliqué
J'ai remplacer la ligne comme vous me l'avez préconisé, mais les pays ne se classent par ordre décroissant.

Je souhaiterais par exemple, si la france à la valeur 1000 en réparation et que la belgique 700. La france soit en 1er (A2) et la belgique en 2eme ( A6).

VB: 
Sub Somme12mgFamilly()
Dim Dic As New Dictionary, ColGig As Collection, T(), Pays As SsGr, _
    Article As SsGr, L As Long, C As Long, S As Double ',M as Currency ?
Set Dic = MGigogne.DicInvent(Worksheets("BDD").[A2:AD2], 24, ColDép:=4)
Set ColGig = Gigogne(Null, 30, 24)
ReDim T(1 To 1 + ColGig.Count * 4, 1 To 4)
MGigogne.VerserTitres T, Dic
L = 1: T(1, 3) = "Total"
Worksheets("Familly & Country").[A18].Resize(UBound(T, 1), UBound(T, 2)).Value = T
For Each Pays In ColGig
   L = L + 1
   T(L, 1) = Pays.Co(1).Co(1)(30): T(L, 2) = "Quantité": T(L + 1, 2) = "Ventes"
   T(L + 2, 2) = "Réparation": T(L + 3, 2) = "% Ventes / Réparation"
   For Each Article In Pays.Co
      C = Dic(Article.Id)
      S = Article.Somme(11): T(L, C) = T(L, C) + S: T(L, 3) = T(L, 3) + S
      S = Article.Somme(12): T(L + 1, C) = T(L + 1, C) + S: T(L + 1, 3) = T(L + 1, 3) + S
      S = Article.Somme(14) + Article.Somme(15) + Article.Somme(16) + Article.Somme(18) + Article.Somme(20)
      T(L + 2, C) = T(L + 2, C) + S: T(L + 2, 3) = T(L + 2, 3) + S
      Next Article
   For C = 3 To UBound(T, 2)
      If T(L + 1, C) <> 0 And T(L + 2, C) <> 0 Then T(L + 3, C) = T(L + 2, C) / T(L + 1, C)
      Next C
   L = L + 3: Next Pays
With Worksheets("Familly & Country")
   .Cells.ClearContents
   .[A1].Resize(UBound(T, 1), UBound(T, 2)).Value = T
   End With
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
506
laurent950
laurent950
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
921
Nicolas JACQUIN
Nicolas JACQUIN
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
2 K
thivame
T
L
  • Question
XL 2016 Erreur 28 : Espace de pile insuffisant
Réponses
6
Affichages
529
patricktoulon
patricktoulon
T
  • Question
Microsoft 365 Problème affichage multipage dans un tabstrip
Réponses
1
Affichages
482
troki74
T
R
  • Question
Microsoft 365 Supprimer les lignes vides d'une variable tableau
Réponses
1
Affichages
536
Phil69970
Phil69970
mromain
Génération de QR Codes
Réponses
1
Affichages
691
Cousinhub
Cousinhub
A
  • Résolu(e)
Microsoft 365 Trop de caractères de continuité de ligne
Réponses
9
Affichages
706
TooFatBoy
TooFatBoy
S
  • Résolu(e)
Microsoft 365 CODE pour vider un formulaire en évitant les doublons
Réponses
11
Affichages
1 K
sgangbadjo
S
J
  • Question
XL 2016 Transformer un nouveau Tableau à double entrée en liste en VBA - impossibilité d'adapter le code
2
Réponses
23
Affichages
1 K
patricktoulon
patricktoulon

Membres actuellement en ligne

19 membres et 373 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 698
Messages
2 111 998
Membres
111 386
dernier inscrit
ltitia.david