Utilisation de Maplage

[erics83]

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

For i =

qui prend beaucoup de temps....d'où mon option d'essayer

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,

 

[fhoest]

Re : Utilisation de Maplage

Bonjour,
voici le résultat en colonne J:

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🙂

 

[mapomme]

Re : Utilisation de Maplage

Bonjour erics83, fhoest,

On peut aussi utiliser un TCD (et des segments à partir d'Excel 2010)

 

[erics83]

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 😀

J'en ai profité pour corriger une coquille :

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]

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,

 

[fhoest]

Re : Utilisation de Maplage

Bonsoir,
essaie comme ça:

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]

Re : Utilisation de Maplage

Bonjour erics83, fhoest, mapomme,

Avec le Dictionary le comptage est très rapide :

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]

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 :

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é]

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.....

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é]

Re : Utilisation de Maplage

Re
Mieux, sans Flag

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]

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 :

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+

 

[Efgé]

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 😀

Cordialement

 

[KIM]

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

 

[Efgé]

Re : Utilisation de Maplage

Bonjour le fil, le forum
Bonjour KIM
Pour ma part cela donnerais ça:

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]

Re : Utilisation de Maplage

Bonjour KIM, Efgé, le fil,

Oui, ou aussi avec un 2ème Dictionary :

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+