Afficher nombre sujets d’élevage par sexe et année
Bonjour à tous,
Dans ma base de données (Feuille : "Parents"), les cellules de la colonne "A", se terminent soit par "M" pour sexe masculin ou par "F" pour le sexe Féminin.
Dans la colonne "H", on retrouve la date de naissance, nous allons prendre en compte seulement l’année.
Dans la colonne "K", on retrouve les sujets gardés pour mon élevage, ils sont représentés par le caractère "x" dans cette même colonne "K".
Le code que je vous demande, se produit lorsqu’on fait le choix du caractère "x" dans la combobox8 du formulaire, de telle manière qu’il nous donne le détail du nombre d’oiseaux gardés pour mon élevage, par sexe et année, et affiche ce résultat dans la feuille Résultat dans les colonnes "M" - "N"- "O" et "P".
Sauf erreur de ma part, le résultat souhaité se trouve dans la feuille "Résultat" aux colonnes "M" - "N"- "O" et "P" à partir de la 2e ligne.
Vous pouvez pour élaborer votre code soit en travaillant sur le formulaire via le combobox8 ou via la feuille "Parents" directement par l’intermédiaire d’un bouton.
Je reste à votre disposition pour d’autres informations supplémentaires.
Salutations.
Bonjour,
mettre plusieurs in dans une seule cellule est une mauvaise idée.
Si tu extrais le sexe du nom un simple tableau croisé dynamique le fait.
A la limite 1 ligne de vba pour éviter le rafraichissement du TCD par un clic droit si les données évolue, et/ou pour corriger la source de données.
Tableau Croisé Dynamique (TCD) : http://www.mdf-xlpages.com/modules/smartsection/item.php?itemid=109
et : Grouper champ date : http://www.mdf-xlpages.com/modules/publisher/item.php?itemid=130
eric
PS : la version (2010) dans ton profil est à jour ?
Bonjour eriiic,
Merci pour votre réponse.
Je souhaite vous informer que j’ai d’autres macros qui travaillent, traitent et récupèrent diverses informations selon la disposition initiale de mes colonnes, le fait d’ajouter une colonne, toutes mes précédentes Marcos, mes formulaires, ne fonctionnent plus puisqu’elles se réfèrent aux colonnes selon leurs dispositions initiales, pour preuve et ceci est un détail parmi d’autres, le calcul de l’âge en fonction de la date de naissance se faisait dans la colonne "Age" et maintenant, il se fait en colonne "Eleveur".
Changer la nature de ma base de données actuelle, c’est changer tous les codes existants du projet, et prendre le risque de découvrir des nouvelles situations qui vont apparaitre avec le temps.
Je suis convaincu qu’il est possible de le faire avec du vba, j’y travaille d’ailleurs de mon côté aussi (malgré que j’ai posté ma demande), mais vu mon niveau en vba j’ai du mal à y parvenir.
Merci encore à vous.
Salutations amicales.
Bonjour,
je suis persuadé qu'il faut que tu prennes le temps d'avoir une BDD correcte.
Là tu traines des boulets qui vont t'handicaper tout le temps.
Ca peut très bien se faire sur une copie jusqu'à ce que ce soit ok.
Une 1ère étape pourrait être de nommer les titres des champs et les utiliser dans le code. Ensuite tu peux les déplacer comme tu veux.
Oui, ça peut se faire en vba, tu peux aussi mettre la nouvelle colonne tout à droite.
Tu n'as pas répondu sur ta version...
eric
Bonjour eriiic,
Merci pour votre réponse,
Je n’ai ni les moyens, ni le niveau pour modifier la base de données de manière à nommer les champs pour les utiliser dans le code, c’est trop compliqué pour moi, ma base de données me sert pour la gestion de mes canaris et me satisfait largement comme elle est.
Merci pour votre conseil, vu mon âge et l’utilisation occasionnelle du projet, je ne tiens pas à rentrer dans des complications que je ne serais gérer.
Pour la version, j’utilise Excel 2010.
Bien à vous.
Bonjour,
Je suis arrivé à trouver une solution pour compter les sujets gardés pour mon élevage, la solution fonctionne bien et me donne le résultat souhaité, le seul problème et que vu la taille de ma base de données, la macro rame un peu.
Je suis convaincu que si on remplace mes deux boucles for simples par deux boucles du genre « For i = LBound(MonArray) To UBound(monArray), le projet tournera beaucoup plus vite, voir peut-être une solution avec dictionnaire.
Merci de me proposer une solution qui tourne plus rapidement.
Salutations.
Public Sub Compter_sujets_Elevage_Par_Annee_et_Sexe()
'''Supprimer les anciennes données
LastRow = Range("AA65536").End(xlUp).Row
StartRow = 2
For x = StartRow To LastRow
Range("AA2:AC" & x).ClearContents
Next x
'''''Extraire année dans une date de naissance, Extraire de la colonne "H" vers la colonne "AA"
Dim tmp As Variant, yrs As Object, i As Long
Set yrs = CreateObject("scripting.dictionary")
With Worksheets("Parents")
'mettre toutes les années dans un tableau pour gagner du temps en parcourant des "milliers d'enregistrements"
tmp = .Range(.Cells(2, "H"), .Cells(.Rows.Count, "H").End(xlUp)).Value2
'transfert vers les clés du dictionnaire sous forme d'années
For i = LBound(tmp, 1) To UBound(tmp, 1)
yrs.Item(Year(tmp(i, 1))) = CStr(vbNullString)
Debug.Print tmp(i, 1)
Next i
'remettre les années uniques dans la colonne "AA"
.Cells(2, "AA").Resize(yrs.Count, 1) = Application.Transpose(yrs.keys)
'trier les années uniques dans la colonne K
With .Range(.Cells(2, "AA"), .Cells(.Rows.Count, "AA").End(xlUp))
.Sort key1:=.Cells(1), order1:=xlAscending, Header:=xlNo
End With
Dim v As Integer
Dim w As Integer
Dim Dl_Col_A As Integer
Dim Dl_Col_AA As Integer
Dim cpt_M As Integer
Dim Cpt_F As Integer
Dim val_Annee As String
Dim année_H As String
Dl_Col_A = .Range("A" & Rows.Count).End(xlUp).Row
Dl_Col_AA = .Range("AA" & Rows.Count).End(xlUp).Row
For v = 2 To Dl_Col_AA 'on parcourt la colonne "AA"
val_Annee = .Cells(v, "AA").Value
cpt_M = 0
Cpt_F = 0
For w = 2 To Dl_Col_A 'on parcourt la colonne "A"
année_H = Year(Cells(w, "H")) 'Extraire l'année pour chaque ligne "w" dans la colonne "H"
If UCase(Right(.Cells(w, "A"), 1)) = "M" And UCase(Cells(w, "K")) = "X" And année_H = val_Annee Then 'on test si le dernier caractère de la colonne A est "F"
cpt_M = cpt_M + 1
.Cells(v, 28) = cpt_M
Tot_M = Tot_M + 1
ElseIf UCase(Right(.Cells(w, "A"), 1)) = "F" And UCase(Cells(w, "K")) = "X" And année_H = val_Annee Then 'fonctionnel
Cpt_F = Cpt_F + 1
.Cells(v, 29) = Cpt_F
Tot_F = Tot_F + 1
End If
Next w
Next v
.Range("AA1:AC1") = Array("Année", "Mâle", "Femelle")
.Cells(v + 1, 27) = "Total"
.Cells(v + 1, 28) = Tot_M
.Cells(v + 1, 29) = Tot_F
.Cells(v + 2, 27) = "Totaux"
.Cells(v + 2, 28) = Tot_M + Tot_F
End With
End Subre,
une solution avec un dictionaire, mais peut-être avec des arrays, cela sera encore plus vite (et plus simple). Quelque chose pour ce soir ?
Sub Avec_Dict()
Dim Dict, aA, i, It, Année, t
t = Timer 'chronomètre
Set Dict = CreateObject("scripting.dictionary")
aA = Sheets("parents").Range("A1").CurrentRegion.Value2 'lire les valeurs de votre plage vers une matrice (concernant vitesse d'exécution)
For i = 2 To UBound(aA) 'boucle tous les données sauf entête
If StrComp(aA(i, 11), "x", 1) = 0 Then 'élevage = x (ou X), donc vos animaux
Année = Year(aA(i, 8)) 'année de naissance
If Not Dict.exists(Année) Then 'premiere fois qu'on voit cette année ?
ReDim It(1 To 10) 'créer une matrice vide de 10 éléments
It(1) = Année 'et directement, premier élément= année
Else 'on a déjà eu cette année
It = Dict(Année) 'récupérer la matrice actuelle de cette année
End If
Select Case UCase(Right(aA(i, 1), 1)) 'majuscule du dernier charactère de "Jeune"
Case "M": It(2) = It(2) + 1 '2ème élément de votre matrice est pour compte les males
Case "F": It(3) = It(3) + 1 '3ème élément de votre matrice est pour compte les femelles
End Select
Dict(Année) = It 'sauvegarder ces nouvelles valeurs dans le dictionaire
End If
Next
i = Dict.Count 'nombre d'années dans le dictionaire
If i = 0 Then MsgBox "rien dans le dictionaire", vbInformation: Exit Sub
If i = 1 Then 'dictionaire avec un record a un problème pour lire le contenu des items avec "index" !!! donc ajoutez un 2ème record "fantôme"
ReDim It(1 To UBound(It)) 'créer une matrice vide d'une dimension juste
Dict.Add "x", It 'ajouter au dictionaire
End If
'à partir d'ici le dictionaire contient au minimum 2 records et le nombre de records intéressant est i, le nombre de éléments est pour le moment 3 : année, males et femelles
With Sheets("parents").Range("N1") 'cellule de référence pour écrire le résultat
.Resize(20, 3).ClearContents 'RAZ cette plage (assez grand !!!)
.Resize(, 3).Value = Array("Année", "Mâle", "Femelle") 'l'entête
With .Offset(1).Resize(i, 3) 'le nombre de records intéressant et pour le moment on a utilisé seulement les 3 premiers éléments, donc ce 3
.Value = Application.Index(Dict.items, 0, 0) 'écrire le contenu des items du dictionaire dans cette plage
.Sort .Range("A1"), xlAscending, Header:=xlNo 'trier sans l'entête la première colonne
End With
End With
MsgBox "prêt en " & Format(Timer - t, "0.00\s"), vbInformation, "Harzer" 'temps d'exécution
End SubBonjour BsAlv,
Merci pour la proposition avec le dictionnaire.
Votre code me donne entièrement satisfaction et avec les résultats souhaités, en plus, il est plus rapide que le mien.
Merci également pour cette proposition en vba et les commentaires inclus, cela me permet d’évoluer et mieux comprendre le code.
Je suis curieux de voir le temps d’exécution de votre éventuelle proposition avec des arrays.
A vous lire.
ReBonjour BsAlv,
Je viens de faire les tests avec ma base de données réelle (de plus au moins 32000 lignes), le résultat est bluffant :
0,79’’ pour votre code, contre 64’’ pour le mien.
Grand MERCI.
voilà avec des matrices, mais le nombre de lignes est trop petit pour voir une différence en temps d'exécution et il faut savoir que l'erreur du chronomètre est au niveau de plusieurs dixièmes de seconde.
Sub Avec_Array()
Dim Dict, aA, aAnnée, aOut, i, ptr As Integer, Année, t
t = Timer 'chronomètre
aA = Sheets("parents").Range("A1").CurrentRegion.Value2 'lire les valeurs de votre plage vers une matrice (concernant vitesse d'exécution)
ReDim aAnnée(1 To UBound(aA)) 'créer une matrice avec le même nombre de ligne que aA (donc suffisament grand) pour récupérer les années "unique"
ReDim aOut(1 To UBound(aA), 1 To 3) 'créer une matrice avec le même nombre de ligne que aA (donc suffisament grand) avec les compteurs
For i = 2 To UBound(aA) 'boucle tous les données sauf entête
If StrComp(aA(i, 11), "x", 1) = 0 Then 'élevage = x (ou X), donc vos animaux
Année = Year(aA(i, 8)) 'année de naissance
r = Application.Match(Année, aAnnée, 0) 'année existe déjà ?
If Not IsNumeric(r) Then
ptr = ptr + 1 'pointer +1
r = ptr 'le r est maintenant ce pointer
aAnnée(ptr) = Année 'ajouter année unique dans aAnnée
aOut(ptr, 1) = Année 'ajouter année dans aOut
End If
Select Case UCase(Right(aA(i, 1), 1)) 'majuscule du dernier charactère de "Jeune"
Case "M": aOut(r, 2) = aOut(r, 2) + 1 '2ème élément de votre matrice est pour compte les males
Case "F": aOut(r, 3) = aOut(r, 3) + 1 '3ème élément de votre matrice est pour compte les femelles
End Select
End If
Next
If ptr = 0 Then MsgBox "rien trouvé", vbInformation: Exit Sub
With Sheets("parents").Range("R1") 'cellule de référence pour écrire le résultat
.Resize(20, 3).ClearContents 'RAZ cette plage (assez grand !!!)
.Resize(, 3).Value = Array("Année", "Mâle", "Femelle") 'l'entête
With .Offset(1).Resize(ptr, UBound(aOut, 2)) 'le nombre de records intéressant et pour le moment on a utilisé seulement les 3 premiers éléments, donc ce 3
.Value = aOut 'écrire le contenu d'aOut dans cette plage
.Sort .Range("A1"), xlAscending, Header:=xlNo 'trier sans l'entête la première colonne
End With
End With
MsgBox "prêt en " & Format(Timer - t, "0.00\s"), vbInformation, "Harzer" 'temps d'exécution
End SubEDIT : j'ai justement vu votre dernière réaction, je pense que cette méthode sera "plus vite"
re, en PJ le fichier avec seulement un autre msgbox (plus détaillé) pour la macro "avec_array"
Bonjour BsAlv,
Tout d’abord, merci pour les deux nouvelles propositions avec des Arrays.
J’ai fait mes tests avec vos marcos respectives, celles avec dico et Arrays, voici donc le résultat du temps d’exécution par rapport à ma base données de plus au moins 32000 lignes.
- Celle qui s’exécute le plus rapidement, est la macro avec Array, votre 2e proposition avec une Msgbox normale, avec un temps de 0,77s.
- Suivi de la macro avec dico, cette dernière est presque proche de la précédente, temps = 0,79s.
- Et enfin, la macro avec la msgbox amélioré, temps d’exécution est de 142,63s, 142,31 pour le comptage et 0,22s pour écrire sur le fichier. Elle est très lente, je ne sais pas, si c’est le fait d’avoir mis cette Msgbox améliorée ? --> Mystère !
Dans tous les cas, j’ai deux macros très rapides et fonctionnelles, je vous remercie de votre disponibilité.
Cordiale poignée de mains.
re,
le 3 = 143 sec, ça, je ne comprends pas, vous êtes sûr ? La première partie est la même chose que l'original ! Et si vous faites le teste une deuxième fois ... .
Une différence de 0.02 s, vue la faute de "timer" de quelque dixièmes d'une seconde, 0,77s = 0,79s or les 2 ont la même vitesse
Bonjour BsAlv
Je vais refaire un nouveau fichier rien qu’avec les trois Macros, je ferais mes tests tard dans la soirée car ce n’est pas facile avec les petits-enfants qui sont en vacances chez nous et demandent toujours de jouer). Je vous communique mon résumé probablement demain dans la matinée, si vous le permettez.
Bonne soirée et à demain.
Bonjour, bonsoir BsAlv, selon,
Les petits-enfants sont montés dormir avec mamy, ça me laisse un peu de temps pour faire mes tests.
Et bien, je ne suis emmêlé les pinceaux, j’ai utilisé deux fois la macro avec dictionnaire et une fois la macro avec la Msgbox améliorée, ça explique tout !
Voici finalement les résultats finaux pour 32000 lignes.
De toute évidence, la macro la plus rapide est celle avec dictionnaire : Essai 1 : 0,77s, Essai 2 : 0,78s, Essai 3 : 0,75s.
La Macro avec la Msgbox normale : Essai 1 : 135,07s, Essai 2 : 135,56s, Essai 3 : 135,03s.
La Macro avec la Msgbox améliorée : Essai 1 : 135,68s, Essai 2 : 135,76s, Essai 3 : 135,86s.
A l’évidence et sans conteste, celle avec le dictionnaire est beaucoup plus rapide que les deux autres, d’ailleurs, je suis rassuré car je ne trouvais pas d’explications de la différence du temps entre Les deux avec Msgbox, surtout que le code est le même à quelques lignes de code près (pour la Msgbox).
Et pourtant, moi aussi, j’aurais cru qu’avec les arrays, l’exécution serait plus rapide.
Enfin voilà les nouvelles, de mon côté, je suis très content et la solution avec dictionnaire me convient parfaitement, merci encore.
Si de votre coté vous souhaitez creuser plus loin avec les Arrays, dans ce cas j’attends de vos nouvelles.
Cordiale poignée de mains.
re,
un nouveau essai !!!
PS. Votre excel est encore Excel2010 ?
Sub Avec_Array2()
'******************************************************************************************************************
'on prepare une matrice avec dans la première colonne toutes les année à partir de l'année la plus petite vers l'année la plus grande de votre colonne H
'si l'année est utilisée, on écrit cette année dans la premièe colonne de aOut et on compte les males et femelles dans les 2 colonnes suivantes
'puis on vérifie si toutes les années sont utilisées et de celles on utilise la ligne, les autres, on les ignore.
'puis on copie & colle les données utiles de aOut vers la feuille
'******************************************************************************************************************
Dim aA, dMin, dMax, aAnnée, aOut, i, r, s, Année, t, t1, sp
t = Timer 'chronomètre
aA = Sheets("parents").Range("A1").CurrentRegion.Value2 'lire les valeurs de votre plage vers une matrice (concernant vitesse d'exécution)
dMin = Year(Application.Min(Application.Index(aA, 0, 8))) 'année de la date la plus petite
dMax = Year(Application.Max(Application.Index(aA, 0, 8))) 'année de la date la plus grande
ReDim aOut(0 To dMax - dMin, 1 To 3) 'preparer matrice, nombre d'annéé = base 0, donc l'index commence avec 0 (important !!!), donc première année est sur la ligne 0
For i = 2 To UBound(aA) 'boucle tous les données sauf entête
If StrComp(aA(i, 11), "x", 1) = 0 Then 'élevage = x (ou X), donc vos animaux
Année = Year(aA(i, 8)) 'année de naissance
r = Year(aA(i, 8)) - dMin 'ligne dans aOut
aOut(r, 1) = Année 'ajouter année dans aOut >>> plus tard, on utilisera seulement les lignes dont le premier élément de aOut n'est pas vide !
Select Case UCase(Right(aA(i, 1), 1)) 'majuscule du dernier charactère de "Jeune"
Case "M": aOut(r, 2) = aOut(r, 2) + 1 '2ème élément de votre matrice est pour compte les males
Case "F": aOut(r, 3) = aOut(r, 3) + 1 '3ème élément de votre matrice est pour compte les femelles
End Select
End If
Next
t1 = Timer 'chronomètre après le comptage
With Sheets("parents").Range("R1") 'cellule de référence pour écrire le résultat
.Resize(, 3).EntireColumn.ClearContents 'RAZ ces colonnes
.Resize(, 3).Value = Array("Année", "Mâle", "Femelle") 'l'entête
s = "" 'commencer avec un string vide
For i = 0 To UBound(aOut) 'boucle 1ère colonne de aOut
If aOut(i, 1) <> "" Then s = s & "|" & i + 1 'l'année est connue, donc un des compteurs est >0 = ajoutez ligne+1 (Base 0) à s (on a besoin de ces lignes dans le prochain INDEX
Next
If s = "" Then MsgBox "rien trouvé", vbInformation: Exit Sub
sp = Split(Mid(s, 2), "|") 'toutes les lignes utiles pour cet INDEX
With .Offset(1).Resize(UBound(sp) + 1, UBound(aOut, 2)) 'le nombre de records intéressants = nombre d'éléments de sp (et parce que sp a le base 0, cest +1
.Value = Application.Index(aOut, Application.Transpose(sp), Array(1, 2, 3)) ' aOut 'écrire le contenu d'aOut dans cette plage
.Sort .Range("A1"), xlAscending, Header:=xlNo 'trier sans l'entête la première colonne
End With
End With
MsgBox "prêt en " & Format(Timer - t, "0.00\s") & vbLf & vbLf & Format(t1 - t, "0.00\s") & " pour le comptage" & vbLf & Format(Timer - t1, "0.00\s") & " pour écrire vers le fichier" & vbLf & vbLf & "erreur du chronomètre = plusieurs dixièmes d'une seconde", vbInformation, "Harzer" 'temps d'exécution
End SubBonjour Bsalv et le forum,
Merci pour la nouvelle proposition avec les Arrays et ses commentaires.
Je l’ai testé ce matin, elle donne les résultats souhaités, de plus, elle est aussi rapide que celle avec dictionnaire, la petite différence toujours en faveur du dictionnaire est insignifiante.
Grand MERCI à vous, me voici avec de très bonnes propositions.
Bravo pour votre patience, efficacité et partage de vos connaissances.
Salutations.