Utilisation de Maplage

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:

fhoest

XLDnaute Accro
Re : Utilisation de Maplage

Bonjour,
voici le résultat en colonne J:
Code:
Sub test()Dim maplage As Range
Dim DerligR1 As Long
Dim c As Range, mem As Integer


With Worksheets("Feuil1")
    DerligR1 = .Range("a" & .Rows.Count).End(xlUp).Row
     Set maplage = .Range(.Cells(1, 1), .Cells(DerligR1, 1))
End With
For i = 1 To 7
For Each c In maplage
If c.Value = "Eric" & i And c.Offset(0, 2).Value = "2015" And c.Offset(0, 4).Value = "OUI" Then mem = mem + 1
Next
Range("J" & i + 7) = mem: mem = 0
Next
End Sub
A bientôt.
edit: bonjour Mapomme:)
 
Dernière édition:

erics83

XLDnaute Impliqué
Re : Utilisation de Maplage

Merci mapomme,

Effectivement, j'avais aussi utilisé les TCD, mais j'ai beaucoup de données changeantes (je ne rentre pas dans le détail), et les TCD étaient un peu galère à utiliser....mais merci de ton aide.

Merci fhoest,

c'est les instructions que je cherchais, merci :D

J'en ai profité pour corriger une coquille :

Code:
If c.Value = "Eric" & i And c.Offset(0, 2).Value = "2015" And c.Offset(0, 1).Value = "1" And c.Offset(0, 4).Value = "OUI" Then mem = mem + c.Offset(0, 3).Value

Je vous remercie pour votre aide,

A+ pour de prochaines aventures....
 

erics83

XLDnaute Impliqué
Re : Utilisation de Maplage

Re-bonjour,

Finalement, je pensais que c'était plus rapide en utilisant Maplage, mais.....

soit je fais une erreur, soit finalement Maplage n'est pas aussi rapide....soit il existe une autre solution.....

Merci pour votre aide,
 

Pièces jointes

  • Classeur1.xlsm
    71.9 KB · Affichages: 58
  • Classeur1.xlsm
    71.9 KB · Affichages: 65

fhoest

XLDnaute Accro
Re : Utilisation de Maplage

Bonsoir,
essaie comme ça:
Code:
Sub test()Dim maplage As Range
Dim DerligR1 As Long
Dim c As Range, mem As Integer
With Worksheets("Feuil1")
     DerligR1 = .Range("a" & .Rows.Count).End(xlUp).Row
     Set maplage = .Range(.Cells(1, 1), .Cells(DerligR1, 1))
End With


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


For i = 8 To 20
For Each c In maplage
If c.Value = Cells(i, 8) Then
If c.Offset(0, 2).Value = "2015" And c.Offset(0, 1).Value = "1" And c.Offset(0, 4).Value = "OUI" Then mem = mem + c.Offset(0, 3).Value
End If
Next
Range("J" & i) = mem: mem = 0
Next


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Pour l'instant je n'ai pas d'autres solutions
A+
 

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Bonjour erics83, fhoest, mapomme,

Avec le Dictionary le comptage est très rapide :

Code:
Sub Comptage()
Dim dest As Range, critere$, t, d As Object, i&
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
For i = 2 To UBound(t)
  If t(i, 1) <> "" And t(i, 2) & t(i, 3) & UCase(t(i, 5)) = critere _
    Then d(t(i, 1)) = d(t(i, 1)) + t(i, 4)
Next
'---restitution---
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1, 2).ClearContents 'RAZ
If d.Count Then
  dest.Resize(d.Count) = Application.Transpose(d.keys)
  dest(1, 2).Resize(d.Count) = Application.Transpose(d.items)
  dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri
End If
End Sub
Pour tester j'ai recopié le tableau principal sur 198000 lignes.

Durée d'exécution sur Win 8 - Excel 2013 => 0,75 seconde.

A+
 

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re,

Attention, Application.Transpose n'accepte pas plus de 65536 lignes.

Si le tableau des résultats peut faire plus de 65536 lignes il faut transposer le Dictionary comme suit :

Code:
Sub Comptage()
Dim dest As Range, critere$, t, d As Object, i&, a, b
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
For i = 2 To UBound(t)
  If t(i, 1) <> "" And t(i, 2) & t(i, 3) & UCase(t(i, 5)) = critere _
    Then d(t(i, 1)) = d(t(i, 1)) + t(i, 4)
Next
Application.ScreenUpdating = False
dest.Resize(Rows.Count - dest.Row + 1, 2).ClearContents 'RAZ
If d.Count Then
  a = d.keys: b = d.items
  ReDim t(UBound(a), 1) 'base 0
  '---transposition---
  For i = 0 To UBound(a)
    t(i, 0) = a(i)
    t(i, 1) = b(i)
  Next
  '---restitution---
  dest.Resize(d.Count, 2) = t
  dest.Resize(d.Count, 2).Sort dest, xlAscending, Header:=xlNo 'tri
End If
End Sub
A+
 

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Bonjour à tous
En repartant du code de job75 (que je salut :) ), et pour éviter le transpose.
Pas certain qu'il y est un gain de temps.....
VB:
Sub Test_Efge()
Dim dest As Range, critere$, t, d As Object, i&, K, Flag
 
Set dest = [H8] 'à adapter
critere = [I6] & [I5] & "OUI" 'à adapter
t = Range(Cells(2, 1), Cells(Rows.Count, 1).End(3)(1, 5))
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
    Flag = False
    If t(i, 1) <> "" And t(i, 2) & t(i, 3) & UCase(t(i, 5)) = critere Then
        If Not d.exists(t(i, 1)) Then
            d(t(i, 1)) = d.Count + 1
            Flag = True
            t(d(t(i, 1)), 1) = t(i, 1)
        End If
        t(d(t(i, 1)), 2) = IIf(Flag = True, 0, t(d(t(i, 1)), 2)) + t(i, 4)
    End If
Next i
dest.Resize(UBound(t, 1), 2).ClearContents
Application.ScreenUpdating = False
If d.Count Then
    With dest.Resize(d.Count, 2)
        .Value = t
        .Sort dest, xlAscending, Header:=xlNo 'tri
    End With
End If
Application.ScreenUpdating = False
End Sub

Cordialement
 

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re
Mieux, sans Flag
VB:
Sub Test_Efge_2()
Dim dest As Range, critere$, t As Variant, d As Object, i&
 
Set dest = [H8] 'à adapter
critere = [I6] & [I5] & "OUI" 'à adapter
t = Range(Cells(2, 1), Cells(Rows.Count, 1).End(3)(1, 5))
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
    If t(i, 1) <> "" And t(i, 2) & t(i, 3) & UCase(t(i, 5)) = critere Then
        If Not d.exists(t(i, 1)) Then
            d(t(i, 1)) = d.Count + 1
            t(d(t(i, 1)), 1) = t(i, 1)
            t(d(t(i, 1)), 2) = 0
        End If
        t(d(t(i, 1)), 2) = t(d(t(i, 1)), 2) + t(i, 4)
    End If
Next i
dest.Resize(UBound(t, 1), 2).ClearContents
Application.ScreenUpdating = False
If d.Count Then
    With dest.Resize(d.Count, 2)
        .Value = t
        .Sort dest, xlAscending, Header:=xlNo 'tri
    End With
End If
Application.ScreenUpdating = False
End Sub
Cordialement
 

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Bonjour Efgé, heureux de te croiser,

En VBA la transposition est quasi instantanée, même sur de très grands tableaux :

Code:
Sub Transposition_65536()
Dim a(), b(), i&,  t
ReDim a(1 To 65536)
ReDim b(1 To 65536, 1 To 1)
For i = 1 To UBound(a): a(i) = 1234567890: Next
t = Timer
b = Application.Transpose (a)
MsgBox Timer - t, , "Fonction": t = Timer
For i = 1 To UBound(a): b(i, 1) = a(i): Next
MsgBox Timer - t, , "Boucle"
End Sub

Sub Transposition_1000000()
Dim a(), b(), i&, t
ReDim a(1 To 1000000)
ReDim b(1 To 1000000, 1 To 1)
For i = 1 To UBound(a): a(i) = 1234567890: Next
t = Timer
For i = 1 To UBound(a): b(i, 1) = a(i): Next
MsgBox Timer - t, , "Boucle"
End Sub
A+
 
Dernière édition:

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Re à tous, re Salut Job75 :)

Nous sommes bien d'accord pour le peu de temps utilisé par un transpose, qu'il soit direct ou item par item.

Je pensai simplement que de remplir un tableau déjà existant directement avec une indexation des lignes (grâce au dictionnaire) pouvait gagner des "pouillèmes" de secondes...


That's all folks :D

Cordialement
 

KIM

XLDnaute Accro
Re : Utilisation de Maplage

Bonjour le fil, Bonjour Job75, Efgé &Fhoest

Ce fil est très intéressant surtout pour la méthode utilisée et le gain de temps d'exécution. J'utilise des formules sommeprod pour le comptage et pour faire la somme selon un critère comme Erics83. vos différents scripts me donne la somme selon le critère affiché de la col D pour chaque nom unique de la col A.
Est-il possible de rajouter en col J, à coté de la somme, pour chaque nom, le nombre de données de la même col D différent de zéro (non null ou vide) utilisées pour calculer cette somme ?

Ci-joint le fichier avec le résultat souhaité.

Merci d'avance pour votre contribution.

Bonne journée

KIM
 

Pièces jointes

  • Comptage_v2.xlsm
    77.6 KB · Affichages: 37

Efgé

XLDnaute Barbatruc
Re : Utilisation de Maplage

Bonjour le fil, le forum
Bonjour KIM
Pour ma part cela donnerais ça:
VB:
Sub Test_Efge_3()
Dim dest As Range, critere$, t As Variant, d As Object, i&
  
Set dest = [H8] 'à adapter
critere = [I6] & [I5] & "OUI" 'à adapter
t = Range(Cells(2, 1), Cells(Rows.Count, 1).End(3)(1, 5))
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 1 To UBound(t)
     If t(i, 1) <> "" And t(i, 2) & t(i, 3) & UCase(t(i, 5)) = critere Then
         If Not d.exists(t(i, 1)) Then
             d(t(i, 1)) = d.Count + 1
             t(d(t(i, 1)), 1) = t(i, 1)
             t(d(t(i, 1)), 2) = 0
             t(d(t(i, 1)), 3) = 0
         End If
         t(d(t(i, 1)), 2) = t(d(t(i, 1)), 2) + t(i, 4)
         If t(i, 4) > 0 Then t(d(t(i, 1)), 3) = t(d(t(i, 1)), 3) + 1
     End If
Next i
dest.Resize(UBound(t, 1), 3).ClearContents
Application.ScreenUpdating = False
If d.Count Then
     With dest.Resize(d.Count, 3)
         .Value = t
         .Sort dest, xlAscending, Header:=xlNo 'tri
    End With
End If
Application.ScreenUpdating = True 'erreur dans le code précédent(remettre à True)
End Sub
Cordialement
 

job75

XLDnaute Barbatruc
Re : Utilisation de Maplage

Bonjour KIM, Efgé, le fil,

Oui, ou aussi avec un 2ème Dictionary :

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, 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+
 

Discussions similaires

Réponses
2
Affichages
129