Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

morest · 30 Mars 2013

Salut à tous,

Voilà je suis confronté à un problème pénible. J'ai créé une macro pour faire l'itération de calcul. Le problème est que c'est très lent et je cherche une méthode pour réduire considérablement le temps de la macro.

Voici donc une fiche excel avec la fameuse macro, en cliquant sur les ovales vous déclenchez celle que j'avais initialement fait ("très lent") puis amélioré ("lent") en cherchant sur le forum avec la fonction "Application.ScreenUpdating = True".

Le but est plutôt simple, chacune des cellules en colonne "A" doit atteindre la valeur en "B". La macro s’arrête après avoir balayé la totalité des possibilités.

Merci beaucoup d'avoir pris le temps de lire mon post et également merci si vous pouvez m'aider.
@+

ROGER2327 · 31 Mars 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Bonsoir à tous.

La question ne brille pas d'une lumière aveuglante... Un essai (assez rapide) tout de même :

VB:

Sub prout()
Dim i%, j%, k%, l%, Msg$, n&, s&, xy(), x%(), y%()

    xy = Range("A1:B4").Value
    s = UBound(xy)
    ReDim x(1 To s, 1 To 1)
    ReDim y(1 To s)
    For i = 1 To s: y(i) = xy(i, 2): Next
    Erase xy

    For i = 1 To y(4)
    For j = 1 To y(1)
    For k = 1 To y(3)
    For l = 1 To y(2)
        
'   Mettre ici la "vérification" souhaitée. Par exemple,
'   "Relever les cas où i*j*k*l est multiple de 5" :

        If i Mod 5 = 0 Or j Mod 5 = 0 Or k Mod 5 = 0 Or l Mod 5 = 0 Then
            n = n + 1
            ReDim Preserve x(1 To s, 1 To n)
            x(1, n) = i: x(2, n) = j: x(3, n) = k: x(4, n) = l
        End If
'

    Next l, k, j, i

    With Range("H2")
        If n > Rows.Count - .Row + 1 Then
            Msg = "Il y a " & Format(n, "# ##0") & " résultats. Ils n'ont pas pu être tous affichés."
            n = Rows.Count - .Row + 1
            ReDim Preserve x(1 To s, 1 To n)
        End If
        With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
        .Resize(Rows.Count - .Row + 1, s).ClearContents
        .Resize(n, s).Value = WorksheetFunction.Transpose(x)
        With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
    End With
    If Len(Msg) Then MsgBox Msg
End Sub

ROGER2327
#6553

Dimanche 8 Clinamen 140 (La Machine à Peindre - fête Suprême Seconde)
10 Germinal An CCXXI, 9,9489h - couvoir
2013-W13-6T23:52:39Z

morest · 31 Mars 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re,

Merci Roger également pour ton aide, bon le niveau de ton code est très élevé j'ai du mal à tout comprendre pour le moment mais ça a l'air extrêmement rapide. Y'aurait il la possibilité de ne pas afficher les valeurs dans des cellules séparées mais que ces valeurs changent dans les cellules A1, A2, A3, A4?

J'ai modifié mon fichier initial pour permettre de comprendre exactement ce que je cherche à faire, même si la finalité peut sembler étrange mais le but devrait être plus clair 🙂 enfin j'espère^^.

@+

morest · 31 Mars 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re,

Voilà ce que j'ai trouvé grâce à vos différent.

Code:

Sub tez()
Dim a, b, c, d As String
Application.ScreenUpdating = False
a = Cells(2, 4)
b = Cells(3, 4)
c = Cells(4, 4)
d = Cells(5, 4)

For w = 1 To d
Cells(4, 1) = w

For x = 1 To c
Cells(3, 1) = x

For y = 1 To b
Cells(2, 1) = y

For Z = 1 To a
Cells(1, 1) = Z
Next
Next
Next
Next
Application.ScreenUpdating = True
End Sub

L'ancien, sur mon pc, faisait 19 secondes pour réaliser le calcul complet alors que ce code fait 9 secondes, c'est encore trop long mais c'est déjà mieux.

Quelqu'un à une idée pour réduire encore?

@+

Dranreb · 31 Mars 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Bonjour.
Tant que vous vous obstinerez à taper dans les cellules pendant le calcul, au lieu de travailler sur des tableaux en mémoire, il n'y aura aucun espoir.

JJ1 · 31 Mars 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Bonjour à tous,
Entièrement d'accord avec Dranreb, (c'est ce que m'avait di Papounet d'ailleurs) et j'avais posté un sujet pour essayer de le résoudre aussi mais impossible car la plage est trop grande pour un Tablo.
https://www.excel-downloads.com/threads/modification-procedure-vba-suite-reponse-de-papounet.203458/
On atteint les limites d'Excel.

Bon AM à tous.

ROGER2327 · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Bonjour à tous.

À morest : tenez compte du message #19 !

Pour ce qui concerne votre classeur du message #17, vous pouvez facilement utiliser le code de mon message #16 : quelques légères modifications suffisent.

VB:

Sub Start()
Dim i&, j&, k&, l&, Msg$, n&, s&, xy(), x&(), y&()
Dim d&

    xy = Range("D2:D5").Value
    d = Range("G6").Value

    s = UBound(xy)
    ReDim x(1 To 1)
    ReDim y(1 To s)
    For i = 1 To s: y(i) = xy(i, 1): Next
    Erase xy

    For i = 1 To y(4)
    For j = 1 To y(1)
    For k = 1 To y(3)
    For l = 1 To y(2)

        If (i * j * k * l) Mod d = 0 Then
            n = n + 1
            ReDim Preserve x(1 To n)
            x(n) = i * j * k * l
            Exit For
        End If

    Next l, k, j, i

    With Range("J1")
        If n > Rows.Count - .Row + 1 Then
            Msg = "Il y a " & Format(n, "# ##0") & " résultats. Ils n'ont pas pu être tous affichés."
            n = Rows.Count - .Row + 1
            ReDim Preserve x(1 To n)
        End If
        With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
        .Resize(Rows.Count - .Row + 1, 1).ClearContents
        If n Then .Resize(n, 1).Value = WorksheetFunction.Transpose(x)
        With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
    End With
    If Len(Msg) Then MsgBox Msg
End Sub

Vous obtiendrez beaucoup plus rapidement exactement les mêmes résultats en colonne J. (Ceci dit, rien ne prouve qu'il n'existe pas de code encore plus rapide...)

Bonne journée.

ROGER2327
#6554

Lundi 9 Clinamen 140 (Sainte Trique, lunatique - fête Suprême Quarte)
11 Germinal An CCXXI, 9,3272h - pervenche
2013-W13-7T22:23:07Z

pierrejean · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Bonjour à tous

Petite étude du problème (avec écriture )
petite amélioration avec start2b (environ 17% plus rapide)
Il s'agit tout de même d’écrire 125 000 combinaisons
Sans écriture on peut avoir (en 4 secondes chez moi) la liste complète des dites combinaisons et des éventuels calculs réalisés avec ces nombres (voir start3 pas vraiment brillant en ecriture)

Arf ! Avais pas vu la prestation de ROGER que je salue (bien bas)

morest · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Salut,

Merci à tous. Grâce à votre aide j'ai pu réduire de 70% le temps de traitement.
@+

ROGER2327 · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re...

morest à dit:
Salut,

Merci à tous. Grâce à votre aide j'ai pu réduire de 70% le temps de traitement.
@+

Parfait si vous êtes satisfaite.
En échange, et parce que nous avons passé du temps sur ce problème, serait-il possible que vous nous dissiez finalement ce que vous avez retenu comme solution ?
Merci d'avance !

ROGER2327
#6557

Mardi 10 Clinamen 140 (Rémission des Poissons - fête Suprême Quarte)
12 Germinal An CCXXI, 3,8213h - charme
2013-W14-1T09:10:16Z

morest · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re,

Voici le code final qui divise par deux le temps de traitement.

Code:

Sub tez()
Application.ScreenUpdating = False
Range("j1:j1000") = ""
a = Cells(2, 4)
b = Cells(3, 4)
c = Cells(4, 4)
d = Cells(5, 4)
g = Range("G6")
For w = 1 To d
Cells(4, 1) = w

For x = 1 To c
Cells(3, 1) = x

For y = 1 To b
Cells(2, 1) = y

For Z = 1 To a
Cells(1, 1) = Z
If Range("G1") Mod g = 0 Then
t = t + 1
Cells(t, 10) = Range("g1")
Exit For
Else
End If
Next
Next
Next
Next
Application.ScreenUpdating = True
End Sub

Me reste plus qu'à trouver un moyen de faire +1 sur la première boucle pour terminer mais je vais probablement trouver cette solution plus tard.
@+

ROGER2327 · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re...

morest à dit:
(...)
Voici le code final qui divise par deux le temps de traitement.
(...)

Merci !
(Et bon courage pour la suite.)

ROGER2327
#6558

Mardi 10 Clinamen 140 (Rémission des Poissons - fête Suprême Quarte)
12 Germinal An CCXXI, 7,3263h - charme
2013-W14-1T17:34:59Z

morest · 1 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re,

Bon je crois que c'est le problème le plus ignoble que j'ai affronté sur vba. Dans ces moments là on s'aperçoit à quel point on est nulle...

J'ai tenté plusieurs solutions avec des exit for, des impositions de valeur pour sortir de la boucle lorsqu'un résultat est trouvé mais rien ne fonctionne. Pour simplifié j'ai diminué la complexité.

Voilà la logique que je cherche à réaliser.

A1 = 1 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 1
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 2
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 2
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 2
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 2

Et à chaque fois qu'un multiple est trouvé la valeur est enregistrée.

Jusque là ça fonctionne nikel. En revanche, je cherche à ce que du moment où un multiple est trouvé alors la macro passe à la solution suivante en faisant A4 = A4 +1 et A1 = 1 / A2 = 1 / A3 = 1.

Je comprends pas ça semble pas si compliqué et avec le Do et Loop c'est facile à faire par contre en For / Next c'est la lutte...

Désolé de vous resolliciter sur ce sujet mais je suis trop juste une nouvelle fois.
Merci, @+

ROGER2327 · 2 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Suite...

Pas sûr d'avoir compris... Peut-être ceci si vous aimez les procédures très-lentes :

VB:

Sub tez()
Dim a&, b&, c&, d&, g&, t&, w&, x&, y&, z&
    Application.ScreenUpdating = False
    Range("J2:J1000") = ""
    a = Cells(2, 4)
    b = Cells(3, 4)
    c = Cells(4, 4)
    d = Cells(5, 4)
    g = Range("G6")
    t = 1
    
    For w = 1 To d
        Cells(4, 1) = w
        
        For x = 1 To c
            Cells(3, 1) = x
            
            For y = 1 To b
                Cells(2, 1) = y
                
                For z = 1 To a
                    Cells(1, 1) = z
                    If Range("G1") Mod g = 0 Then
                        t = t + 1
                        Cells(t, 10) = Range("G1")
                        y = b
                        x = c
                        Exit For
                    End If
                Next z
            Next y
        Next x
    Next w
    Application.ScreenUpdating = True
End Sub

Au cas où vous préféreriez rouler quelques centaines, voire milliers, de fois plus vite, ceci :

VB:

Sub Start()
Dim i&, j&, k&, l&, Msg$, n&, s&, xy(), x&(), y&()
Dim d&

    xy = Range("D2:D5").Value
    d = Range("G6").Value

    s = UBound(xy)
    ReDim x(1 To 1)
    ReDim y(1 To s)
    For i = 1 To s: y(i) = xy(i, 1): Next
    Erase xy
    
    For i = 1 To y(4)
    For j = 1 To y(3)
    For k = 1 To y(2)
    For l = 1 To y(1)

        If (i * j * k * l) Mod d = 0 Then
            n = n + 1
            ReDim Preserve x(1 To n)
            x(n) = i * j * k * l
            j = y(3)
            k = y(2)
            Exit For
        End If

    Next l, k, j, i

    With Range("J2")
        If n > Rows.Count - .Row + 1 Then
            Msg = "Il y a " & Format(n, "# ##0") & " résultats. Ils n'ont pas pu être tous affichés."
            n = Rows.Count - .Row + 1
            ReDim Preserve x(1 To n)
        End If
        With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
        .Resize(Rows.Count - .Row + 1, 1).ClearContents
        If n Then .Resize(n, 1).Value = WorksheetFunction.Transpose(x)
        With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
    End With
    If Len(Msg) Then MsgBox Msg
End Sub

Bonne journée.

ROGER2327
#6559

Mercredi 11 Clinamen 140 (Saint Maquereau, Intercesseur - fête Suprême Quarte)
13 Germinal An CCXXI, 0,3857h - morille
2013-W14-2T00:55:32Z

pierrejean · 2 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re

très troublé par différents tests
Dans le fichier joint:
En colonne J le résultat de la macro tez
En colonne L le résultat de la macro start (ROGER)
En colonne N le résultat de la macro startb (ROGER adaptée uniquement des résultats différents)
En colonne P le résultat de la macro essai (pierrejean)

ROGER2327 · 2 Avril 2013

Re : Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

Re...

pierrejean à dit:
(...)
très troublé par différents tests
(...)

Pour l'instant, je ne suis pas troublé. Depuis le début de cette discussion, nous ignorons le but poursuivi. Rien d'étonnant à ce que nous ayons des intuitions différentes conduisant à des propositions différentes.

En réalité, je suis un peu perturbé tout de même. Lorsque je vois :

morest à dit:
(...)

Voilà la logique que je cherche à réaliser.

A1 = 1 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 1
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 2
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 2
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 2
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 2

Et à chaque fois qu'un multiple est trouvé la valeur est enregistrée.

(...)

je me demande pourquoi je ne vois pas :

morest à dit:
(...)

Voilà la logique que je cherche à réaliser.

A1 = 1 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 1
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 1
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 1
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 1 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 1 / A4 = 2
A1 = 2 / A2 = 1 / A3 = 1 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 2 / A3 = 1 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 1 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 1 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 1 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 1 / A2 = 2 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4
A1 = 2 / A2 = 2 / A3 = 2 / A4 = 2 ->>> Enregistrement puis arret pour faire A4 = A4 + 1 car multiple de 4

Et à chaque fois qu'un multiple est trouvé la valeur est enregistrée.

(...)

Que 2*2*1*1 soit multiple de 4 ne m'étonne pas trop ; que 2*1*2*1, ou 2*2*2*1 ne soient pas multiples de 4 m'étonne un peu plus...

Attendons la suite...

ROGER2327
#6561

Mercredi 11 Clinamen 140 (Saint Maquereau, Intercesseur - fête Suprême Quarte)
13 Germinal An CCXXI, 5,5529h - morille
2013-W14-2T13:19:37Z

Difficultés pour améliorer la rapidité d'une itération lourde. (Macro)

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

JJ1

Guest

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency