Utilisation de Maplage

E

erics83

XLDnaute Impliqué
Bonjour,

J'ai un classeur avec une feuille très chargée (~100000 lignes), sur laquelle je dois faire des requêtes.

Pour l'instant j'ai tout plein de tableaux qui analysent les données, via des SOMMEPROD, mais c'est trop long (j'ai mis un exemple dans le classeur).

J'ai essayé aussi la solution
Code: 
For i =
qui prend beaucoup de temps....d'où mon option d'essayer
Code: 
Dim maplage As Range
Dim DerligR1 As Long


With Worksheets("Feuil1")
    DerligR1 = .Range("a" & .Rows.Count).End(xlUp).Row
     Set maplage = .Range(.Cells(1, 1), .Cells(DerligR1, 61))
End With

Mais je ne sais pas comment faire pour mes requêtes..... :

Par exemple, (dans mon classeur exemple) , compter le nombre (=colonne D) pour le mois de Janvier 2015 pour Eric1, avec la condition "OUI",

Mais je ne sais pas comment l'écrire.....

Une petite aide ?

En vous remerciant,
 

Pièces jointes

  • Classeur1.xlsx
    62.9 KB · Affichages: 64
  • Classeur1.xlsx
    62.9 KB · Affichages: 51
Dernière édition:
Trier par date Trier par votes
K

KIM

XLDnaute Accro
Re : Utilisation de Maplage

Re le fil,
Merci Efgé, cela fonctionne bien.
Je vais essayer de l'adapter à mon tableau.
Par contre, je n'ai pas de critere = [I6] & [I5] & "OUI", mon récap est par année et par nom (Année ; nom; somme; nbre).

Comment l'adapter sur le même exemple ?


PS: Les messages se sont croisés, merci Job75, je regarde.

Merci d'avance.
KIM
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re, salut gosselien,

Ah oui, vous voulez compter seulement les t(i, 4) > 0 donc l'ajouter dans le test :

Code: 
Sub Comptage()
Dim dest As Range, critere$, t, d As Object, dc As Object, i&, a, b, c
Set dest = [H8] 'à adapter
critere = [I6] & [I5] & "OUI" 'à adapter
t = [A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set dc = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If t(i, 1) <> "" And t(i, 4) > 0 And t(i, 2) & t(i, 3) & UCase(t(i, 5)) = critere _
    Then d(t(i, 1)) = d(t(i, 1)) + t(i, 4): dc(t(i, 1)) = dc(t(i, 1)) + 1
Next
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1, 3).ClearContents 'RAZ
If d.Count Then
  a = d.keys: b = d.items: c = dc.items
  ReDim t(UBound(a), 2) 'base 0
  '---transposition---
  For i = 0 To UBound(a)
    t(i, 0) = a(i): t(i, 1) = b(i): t(i, 2) = c(i)
  Next
  '---restitution---
  dest.Resize(d.Count, 3) = t
  dest.Resize(d.Count, 3).Sort dest, xlAscending, Header:=xlNo 'tri
End If
End Sub
A+
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re à tous, Bonjour gosselin



@ KIM
Comme indiqué par gosselin, sans un exemple réel de la structure de base, il va être difficile d'y aller à taton.....


A te relire avec un fichier.
Cordialement
 
Vote positif 0 Vote négatif
K

KIM

XLDnaute Accro
Re : Utilisation de Maplage

Re le fil & le forum,

@Job75, en testant j'ai remarqué que le script ne prend pas en compte les données de la col D > 0.
Merci pour le nouveau script. je teste.

@Gosselien,
En effet j'ai envoyé un fichier dans mon post #13. Je croyais que les explications du post #16 étaient suffisantes. Désolé. Je vous transmet un nouveau fichier avec le résultat souhaité.

Merci encore
KIM
 

Pièces jointes

  • Comptage_v3.xlsm
    79 KB · Affichages: 41
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re
Ma version mise à jour:
VB: 
Option Explicit
Sub Test_Efge_4()
Dim dest As Range, t As Variant, d As Object, i&, Ky$, Nb&
   
Set dest = [G8] 'à adapter
t = Range(Cells(2, 1), Cells(Rows.Count, 1).End(3)(1, 5))
Set d = CreateObject("Scripting.Dictionary")


For i = 1 To UBound(t)
    Ky = Trim(t(i, 3)) & Trim(t(i, 1))
    Nb = t(i, 4)
    If Not d.exists(Ky) Then
        d(Ky) = d.Count + 1
        t(d(Ky), 2) = t(i, 1)
        t(d(Ky), 1) = t(i, 3)
        t(d(Ky), 3) = 0
        t(d(Ky), 4) = 0
    End If
    t(d(Ky), 3) = t(d(Ky), 3) + Nb
    If Nb > 0 Then t(d(Ky), 4) = t(d(Ky), 4) + 1
Next i


Application.ScreenUpdating = False
dest.Resize(UBound(t, 1), 4).ClearContents
If d.Count Then
      With dest.Resize(d.Count, 4)
          .Value = t
          .Sort dest, xlAscending, Header:=xlNo 'tri
    End With
End If
Application.ScreenUpdating = True
End Sub
Cordialement
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re,

Avec 4 Dictionary :

Code: 
Sub Comptage()
Dim dest As Range, t, d1 As Object, d2 As Object, d3 As Object
Dim d4 As Object, i&, x$, a, b, c, d
Set dest = [G8] 'à adapter
t = [A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Set d4 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If t(i, 1) <> "" And t(i, 4) <> 0 Then 'And UCase(t(i, 5)) = "OUI" ?
    x = LCase(t(i, 1)) & t(i, 3) 'nom + année
    d1(x) = t(i, 3): d2(x) = t(i, 1)
    d3(x) = d3(x) + t(i, 4): d4(x) = d4(x) + 1
   End If
Next
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1, 4).ClearContents 'RAZ
If d1.Count Then
  a = d1.items: b = d2.items: c = d3.items: d = d4.items
  ReDim t(UBound(a), 3) 'base 0
  '---transposition---
  For i = 0 To UBound(a)
    t(i, 0) = a(i): t(i, 1) = b(i): t(i, 2) = c(i): t(i, 3) = d(i)
  Next
  '---restitution---
  dest.Resize(d1.Count, 4) = t
  dest.Resize(d1.Count, 4).Sort dest, xlAscending, dest(1, 2), , xlAscending, Header:=xlNo 'tri
End If
End Sub
Si l'on veut ne pas compter les valeurs négatives, remplacer t(i, 4) <> 0 par t(i, 4) > 0

A+
 
Vote positif 0 Vote négatif
K

KIM

XLDnaute Accro
Re : Utilisation de Maplage

Re le fil, Job75, Efgé

Merci pour votre contribution. Vos derniers scripts donnent les résultats souhaités.
@Job75, Résultat attendu OK, j'ai même intégré le test [ And UCase(t(i, 5)) = "OUI" ]
@ Efgé,
Le résultat du script est trié pour 2015 seulement et non pour 2016.
Est-ce que la dernière col E est prise en compte dans les tableaux dynamiques ? et si oui où Est-ce je peux intégrer
le test [ And UCase(t(i, 5)) = "OUI" ] ?

Merci encore à vous deux, merci le fil et le forum.
KIM
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re,

4 Dictionary c'est quand même lourding... Alors un seul comme Efgé :

Code: 
Sub Comptage()
Dim dest As Range, t, d As Object, i&, x$, n&
Set dest = [G8] 'à adapter
t = [A1].CurrentRegion.Resize(, 5) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(t)
  If t(i, 1) <> "" And t(i, 4) <> 0 Then 'And UCase(t(i, 5)) = "OUI" ?
    x = LCase(t(i, 1)) & t(i, 3) 'nom + année
    If Not d.exists(x) Then
      d(x) = d.Count + 1 'mémorisation de la ligne
      n = d(x)
      t(n, 1) = t(i, 3): t(n, 2) = t(i, 1): t(n, 3) = 0: t(n, 4) = 0
    End If
    n = d(x)
    t(n, 3) = t(n, 3) + t(i, 4): t(n, 4) = t(n, 4) + 1
   End If
Next
'---restitution---
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1, 4).ClearContents 'RAZ
If d.Count Then
  dest.Resize(d.Count, 4) = t
  dest.Resize(d.Count, 4).Sort dest, xlAscending, dest(1, 2), , xlAscending, Header:=xlNo 'tri
End If
End Sub
Les résultats sont les mêmes sauf un, Efgé aurait dû écrire If Nb <> 0 au lieu de If Nb > 0...

A+
 
Vote positif 0 Vote négatif
K

KIM

XLDnaute Accro
Re : Utilisation de Maplage

Re le fil, le forum,
Merci encore,
@Job75, en effet j'ai testé le script de Efgé avec If Nb <> 0 au lieu de If Nb > 0 ce qui m'a donné les mêmes résulté que le tien.
@Efgé, Dans le script de Job75 il y avait encore la possibilité de rajouter ce test. C'était une curiosité de ma part pour savoir si j'ai bien lu ton code et je n'ai pas trouvé la possibilité de l'ntégrer.

Bonne fin de journée et merci pour votre contribution
KIM
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re
C'est ici que ça se passe:
VB: 
For i = 1 To UBound(t)
    If UCase(t(i, 5)) = "OUI" Then ' condition
        Ky = Trim(t(i, 3)) & Trim(t(i, 1))
        Nb = t(i, 4)
        If Not d.exists(Ky) Then
            d(Ky) = d.Count + 1
            t(d(Ky), 2) = t(i, 1)
            t(d(Ky), 1) = t(i, 3)
            t(d(Ky), 3) = 0
            t(d(Ky), 4) = 0
        End If
        t(d(Ky), 3) = t(d(Ky), 3) + Nb
        If Nb <> 0 Then t(d(Ky), 4) = t(d(Ky), 4) + 1
     End If' Fin de condition
Next i
Cordialement
 
Vote positif 0 Vote négatif
K

KIM

XLDnaute Accro
Re : Utilisation de Maplage

Bonjour le fil, le forum, Bonjour Job75 & Efgé,
Merci pour ces 2 macros. Exécution correcte et rapide sur un fichier de plusieurs centaine de lignes. Je reviens vers vous pour la présentation du résultat. Est-il possible d'avoir, comme résultat, dans une autre feuille du classeur, les noms comme titre de colonne et en ligne l'année, la somme et le nombre par année. voir fichier joint

Par avance merci de votre aide
KIM
 

Pièces jointes

  • KB_Comptage_v5.xlsm
    76.5 KB · Affichages: 30
  • KB_Comptage_v5.xlsm
    76.5 KB · Affichages: 30
Vote positif 0 Vote négatif

Discussions similaires

E
  • Résolu(e)
Microsoft 365 Ajout et Suppression Date automatique
Réponses
9
Affichages
193
eric72
E
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
281
Dranreb
Dranreb
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
470
Phil69970
Phil69970
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
153
eric72
E
V
  • Question
XL 2016 Durée entre deux horaires de cellules non vides en TCD
Réponses
2
Affichages
165
Vincent C
V
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
363
M@xu3L
M
E
  • Résolu(e)
XL 2019 inserer une valeur textbox dans la dernière cellule vide horizontalement
Réponses
7
Affichages
325
escudo
E
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
155
marie3107
M
P
  • Question
XL 2019 Copier des cellules d'une feuille sur une autre
Réponses
2
Affichages
234
phoceenjo
P
D
  • Question
Microsoft 365 Dupliquer des lignes dans une autre feuille avec une condition
2
Réponses
26
Affichages
1 K
de_hanstrapp
D

Membres actuellement en ligne

6 membres et 40 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
312 229
Messages
2 086 425
Membres
103 206
dernier inscrit
diambote