améliorer la vitesse d'une macro

kevenpom

XLDnaute Junior
Bonjour a tous,
j'utilise ce code pour créer toute les possibilité de 6 feuille excel, Sans titre.jpgmais la compilation prend des heures.

je fait End(xlUp).Row pour définir le nombre de ligne sur chacune de mes colonnes.
Je ne voit pas d'autre type d'approche, avez vous déjà eu ce genre de problème?

Code:
Sub createall()

    Dim WS1 As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim l, m, n, o, p, q, r, s, t, u, v, w, A1, B1, C1, D1, E1, F1, G1, H1, I1, J1, K1, L1, M1, N1, O1, ROUND As Integer
    Dim  lastrow As Long
    
For ROUND = 1 To 6
If ROUND = 1 Then Set WS1 = ThisWorkbook.Sheets("P1")
If ROUND = 2 Then Set WS1 = ThisWorkbook.Sheets("P2")
If ROUND = 3 Then Set WS1 = ThisWorkbook.Sheets("P3")
If ROUND = 4 Then Set WS1 = ThisWorkbook.Sheets("P4")
If ROUND = 5 Then Set WS1 = ThisWorkbook.Sheets("P5")
If ROUND = 6 Then Set WS1 = ThisWorkbook.Sheets("P6")
    A1 = WS1.Range("A65536").End(xlUp).Row
    B1 = WS1.Range("B65536").End(xlUp).Row
    C1 = WS1.Range("C65536").End(xlUp).Row
    D1 = WS1.Range("D65536").End(xlUp).Row
    E1 = WS1.Range("E65536").End(xlUp).Row
    F1 = WS1.Range("F65536").End(xlUp).Row
    G1 = WS1.Range("G65536").End(xlUp).Row
    H1 = WS1.Range("H65536").End(xlUp).Row
    I1 = WS1.Range("I65536").End(xlUp).Row
    J1 = WS1.Range("J65536").End(xlUp).Row
    K1 = WS1.Range("K65536").End(xlUp).Row
    L1 = WS1.Range("L65536").End(xlUp).Row
    M1 = WS1.Range("M65536").End(xlUp).Row
    N1 = WS1.Range("N65536").End(xlUp).Row
    O1 = WS1.Range("O65536").End(xlUp).Row
    
    Application.ScreenUpdating = False
   lastrow = 10

    For i = 1 To A1: For j = 1 To B1
    For k = 1 To C1: For l = 1 To D1
    For m = 1 To E1: For n = 1 To F1
    For o = 1 To G1: For p = 1 To H1
    For q = 1 To I1: For r = 1 To J1
    For s = 1 To K1: For t = 1 To L1
    For u = 1 To M1: For v = 1 To N1
    For w = 1 To O1
        WS1.Range("v" & lastrow).Value = _
        WS1.Range("A" & i).Value & WS1.Range("B" & j).Value & WS1.Range("C" & k).Value & WS1.Range("D" & l).Value & _
        WS1.Range("E" & m).Value & WS1.Range("F" & n).Value & WS1.Range("G" & o).Value & WS1.Range("H" & p).Value & _
        WS1.Range("I" & q).Value & WS1.Range("J" & r).Value & WS1.Range("K" & s).Value & WS1.Range("L" & t).Value & _
        WS1.Range("M" & u).Value & WS1.Range("N" & v).Value & WS1.Range("O" & w).Value & "00000"
        lastrow = lastrow + 1
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next
Next
    Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • Sans titre.jpg
    Sans titre.jpg
    48 KB · Affichages: 110
  • Sans titre.jpg
    Sans titre.jpg
    48 KB · Affichages: 120

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : améliorer la vitesse d'une macro

Bonjour kevenpom,

L'imbrication de boucles peut vite aboutir à des temps d'exécution prohibitifs. Voir le tableau bleuté qui donne quelques exemples de nombres de cellules à calculer (équivalent au nombre de passages dans les boucles de la macro).

Pour accélérer le code, on peut utiliser des tableaux plutôt que de constamment lire des données issues des feuilles de calcul. C'est ce que fait la macro createall_2().

Le transfert des résultats sur la feuille échoue sur ma bécane :mad: si le tableau des résultats est trop grand. C'est pourquoi j'ai découpé l'affichage des résultats en tranche de 30 000 éléments (valeur de la constante limite).

Le tableau gris permet de choisir l'intervalle des feuilles à calculer.

Si le résultat comprend plus d'éléments que ne peut contenir la colonne V, alors on ne fait rien et on passe, le cas échéant, au traitement de la feuille suivante.

On afffiche pour chaque feuille le nombre théorique de cellules à afficher, le temps d'exécution pour la feuille ainsi que le nombre réel de cellules que la macro a traité.

nota 1: vous avez utilisé la variable ROUND comme indice de boucle. Il vaut mieux éviter de nommer des variables comme mot clef de VBA (ROUND est la fonction qui renvoit l'arrondi d'un nombre)

nota 2: Un fichier joint à votre demande eût été grandement apprécié.

L'image jointe en annexe montre les temps d'exécution sur ma "vieille bécane". La méthode par tableau est sensiblement plus rapide :).

améliorer la vitesse d'une macro v2.jpg

Edit v2 : idem v1 mais les données correspondent au tableau comparatif!

Le code de createall_2() :
VB:
 Sub createall_2()
Const Limite = 30000

    Dim WS1 As Worksheet
    Dim Apartir_de_Pn, Jusqu_a_Pn
    Dim i As Long, j As Long, k As Long
    Dim l, m, n, o, p, q, r, s, t, u, v, w, A1, B1, C1, D1, E1, F1, G1, H1, I1, J1, K1, L1, M1, N1, O1, ind As Integer
    Dim lastrow As Long, T0 As Double, Source, tablo(), max As Long, ligne As Long
    Dim CelluleDeb, restante As Long
    
Apartir_de_Pn = Sheets("P1").Range("aa12")
Jusqu_a_Pn = Sheets("P1").Range("aa13")

For ind = Apartir_de_Pn To Jusqu_a_Pn
T0 = Timer
If ind = 1 Then Set WS1 = ThisWorkbook.Sheets("P1")
If ind = 2 Then Set WS1 = ThisWorkbook.Sheets("P2")
If ind = 3 Then Set WS1 = ThisWorkbook.Sheets("P3")
If ind = 4 Then Set WS1 = ThisWorkbook.Sheets("P4")
If ind = 5 Then Set WS1 = ThisWorkbook.Sheets("P5")
If ind = 6 Then Set WS1 = ThisWorkbook.Sheets("P6")
    A1 = WS1.Range("A65536").End(xlUp).Row: max = A1
    B1 = WS1.Range("B65536").End(xlUp).Row: If B1 > max Then max = B1
    C1 = WS1.Range("C65536").End(xlUp).Row: If C1 > max Then max = C1
    D1 = WS1.Range("D65536").End(xlUp).Row: If D1 > max Then max = D1
    E1 = WS1.Range("E65536").End(xlUp).Row: If E1 > max Then max = E1
    F1 = WS1.Range("F65536").End(xlUp).Row: If F1 > max Then max = F1
    G1 = WS1.Range("G65536").End(xlUp).Row: If G1 > max Then max = G1
    H1 = WS1.Range("H65536").End(xlUp).Row: If H1 > max Then max = H1
    I1 = WS1.Range("I65536").End(xlUp).Row: If I1 > max Then max = I1
    J1 = WS1.Range("J65536").End(xlUp).Row: If J1 > max Then max = J1
    K1 = WS1.Range("K65536").End(xlUp).Row: If K1 > max Then max = K1
    L1 = WS1.Range("L65536").End(xlUp).Row: If L1 > max Then max = L1
    M1 = WS1.Range("M65536").End(xlUp).Row: If M1 > max Then max = M1
    N1 = WS1.Range("N65536").End(xlUp).Row: If N1 > max Then max = N1
    O1 = WS1.Range("O65536").End(xlUp).Row: If O1 > max Then max = O1
   
    lastrow = 10
    Source = WS1.Range(WS1.Range("A1"), WS1.Range("O" & max)).Value
    WS1.Range("v" & lastrow & ":v" & Rows.Count).ClearContents
    WS1.Range("v2") = ""
    If WS1.Range("v8") <> "OK" Then Exit For
    Application.ScreenUpdating = False
    restante = WS1.Range("V1")
    If restante < Limite Then
      ReDim tablo(1 To restante)
    Else
      ReDim tablo(1 To Limite)
    End If
    ligne = 0
    Set CelluleDeb = WS1.Range("v" & lastrow)
    For i = 1 To A1: For j = 1 To B1
    For k = 1 To C1: For l = 1 To D1
    For m = 1 To E1: For n = 1 To F1
    For o = 1 To G1: For p = 1 To H1
    For q = 1 To I1: For r = 1 To J1
    For s = 1 To K1: For t = 1 To L1
    For u = 1 To M1: For v = 1 To N1
    For w = 1 To O1
        ligne = ligne + 1
        tablo(ligne) = _
        Source(i, 1) & Source(j, 2) & Source(k, 3) & Source(l, 4) & _
        Source(m, 5) & Source(n, 6) & Source(o, 7) & Source(p, 8) & _
        Source(q, 9) & Source(r, 10) & Source(s, 11) & Source(t, 12) & _
        Source(u, 13) & Source(v, 14) & Source(w, 15) & "00000"
        If ligne = Limite Then
          CelluleDeb.Resize(UBound(tablo)) = Application.Transpose(tablo)
          ligne = 0
          restante = restante - 30000
          Set CelluleDeb = CelluleDeb.Offset(Limite)
          If restante = 0 Then
            Exit For
          ElseIf restante >= Limite Then
            ReDim tablo(1 To Limite)
          Else
            ReDim tablo(1 To restante)
          End If
        End If
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    Next: Next
    If ligne <> 0 Then CelluleDeb.Resize(UBound(tablo)) = Application.Transpose(tablo)
    Next
    WS1.Range("v2") = Timer - T0
Next
    Application.ScreenUpdating = True
    Application.Goto WS1.Range("A1"), True
End Sub
 

Pièces jointes

  • améliorer la vitesse d'une macro v2.xlsm
    158.7 KB · Affichages: 104
Dernière édition:

kevenpom

XLDnaute Junior
Re : améliorer la vitesse d'une macro

Merci mapomme,

25600 possibilité en 1 minute.... incroyable.
Je comprend le principe du tableau, mais avec ou je suis rendu je ne comprend pas comment utilisé ton code pour ma prochaine étape.
avec chacun des 25600 possibilité je doit rattache la composition de chacune des possibilite...

Un dernier coup de main serait apprécier.

Sans titre.jpg
Code:
Dim i As Long, j As Long, k As Long, l, m, n, o, p, q, r, s, t, u, v, w As Long
Dim pompeselection, donne As String
k = 1


For m = 1 To Worksheets("decomposition").Range("A65536").End(xlUp).Row
pompeselection = Worksheets("decomposition").Cells(m, 1).Text
l = 2
For i = 10 To 87
 k = 1
    If Worksheets("selection").Cells(i, 1).Text = Mid(pompeselection, 1, 2) Or Worksheets("selection").Cells(i, 1).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 2).Text = Mid(pompeselection, 3, 3) Or Worksheets("selection").Cells(i, 2).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 3).Text = Mid(pompeselection, 6, 1) Or Worksheets("selection").Cells(i, 3).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 4).Text = Mid(pompeselection, 7, 1) Or Worksheets("selection").Cells(i, 4).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 5).Text = Mid(pompeselection, 8, 2) Or Worksheets("selection").Cells(i, 5).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 6).Text = Mid(pompeselection, 10, 1) Or Worksheets("selection").Cells(i, 6).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 7).Text = Mid(pompeselection, 11, 1) Or Worksheets("selection").Cells(i, 7).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 8).Text = Mid(pompeselection, 12, 1) Or Worksheets("selection").Cells(i, 8).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 9).Text = Mid(pompeselection, 13, 1) Or Worksheets("selection").Cells(i, 9).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 10).Text = Mid(pompeselection, 14, 1) Or Worksheets("selection").Cells(i, 10).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 11).Text = Mid(pompeselection, 15, 2) Or Worksheets("selection").Cells(i, 11).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 12).Text = Mid(pompeselection, 17, 1) Or Worksheets("selection").Cells(i, 12).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 13).Text = Mid(pompeselection, 18, 1) Or Worksheets("selection").Cells(i, 13).Value = "" Then k = k + 1
    If Worksheets("selection").Cells(i, 14).Text = Mid(pompeselection, 19, 1) Or Worksheets("selection").Cells(i, 14).Value = "" Then k = k + 1
    If k = 15 Then
        Worksheets("decomposition").Cells(m, l).Value = Worksheets("selection").Cells(i, 17).Value
        l = l + 1
        If i = 59 Or i = 60 Then
        Worksheets("decomposition").Cells(m, 16).Value = Worksheets("selection").Cells(i, 18).Value
        End If
    End If
    Next
  Next
End Sub
 

Pièces jointes

  • Sans titre.jpg
    Sans titre.jpg
    28.6 KB · Affichages: 90
  • Sans titre.jpg
    Sans titre.jpg
    28.6 KB · Affichages: 93

mécano41

XLDnaute Accro
Re : améliorer la vitesse d'une macro

Bonjour à tous,

Je n'ai pas compris ce que tu souhaites faire dans ton dernier message... à tout hasard, je mets ce que j'ai fait... c'est un peu plus long en exécution que ce qu'à fait MaPomme (je n'ai pas mesuré mais au pif 2 à 3 s par feuille pour les éléments que tu as mis) car je passe par un tableau des données combinées mais non concaténées qui peut éventuellement te permettre de sortir des éléments intéressants.

Attention, les limites peuvent être atteintes rapidement puisque le nb. total de combinaisons est égal au produit de tous les nombres de lignes des 15 colonnes (ici 7680) et ce n'est pas contrôlé par le code.

J'ai joint un dessin des tableaux virtuels pour faciliter la compréhension dans la deuxième feuille ; ce n'est qu'un exemple (non fonctionnel)

EDIT : Je change le fichier. Le résultat ne change pas (mais code plus logique ; il y avait un décalage de lignes entre l'explication et la réalité)

EDIT 2 : attention à ne rien mettre dans la feuille dans la colonne à gauche du Tso ni dans la ligne au-dessus des Tso et TCo car les infos seraient écrasées lors de la sortie


Cordialement
 

Pièces jointes

  • EssaiCombi3.xlsm
    105.3 KB · Affichages: 89
Dernière édition:

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : améliorer la vitesse d'une macro

Bonsoir kevenpom :) ,
(...) Je comprend le principe du tableau, mais avec ou je suis rendu je ne comprend pas comment utilisé ton code pour ma prochaine étape. avec chacun des 25600 possibilité je doit rattache la composition de chacune des possibilite...
Un dernier coup de main serait apprécier.(...)

Un fichier exemple serait apprécié également...

A+
 

kevenpom

XLDnaute Junior
Re : améliorer la vitesse d'une macro

Bonjour Mapomme,

voici le fichier en pièce jointe.
donc avec les 25600 possibilité
je souhaite pouvoir apartir de la composition de chaque item identifier la composante qui si ratache
merci de ton aide
 

Pièces jointes

  • teste.xlsm
    661.5 KB · Affichages: 91
  • teste.xlsm
    661.5 KB · Affichages: 106
  • teste.xlsm
    661.5 KB · Affichages: 88

kevenpom

XLDnaute Junior
Re : améliorer la vitesse d'une macro

Bonjour,


J'ai réussi a utilise un tableau avec beacoup de temp, mais comment faire pour au lieu d'écrire dans les cellules mais de stocker dans un tableau pour a la fin le coller d'un seul coup le tableau


voici mon code :
Code:
    If k = 15 Then
        Worksheets("decomposition").Cells(m, l).Value = Worksheets("selection").Cells(i, 17).Value
        l = l + 1
        If i = 59 Or i = 60 Then
        Worksheets("decomposition").Cells(m, 16).Value = Worksheets("selection").Cells(i, 18).Value
        End If
    End If

Style de code que Lapomme m'as donné....que je ne comprend pas comment adapter.

Code:
          CelluleDeb.Resize(UBound(tablo)) = Application.Transpose(tablo)
          ligne = 0
          restante = restante - 30000
          Set CelluleDeb = CelluleDeb.Offset(Limite)


Code:
Sub partlist()

Dim WS1, WS2 As Worksheet
Dim lastrow, lastrow2, Source, source2, tablo(), max, max2, i, l, k, m As Long
Dim CelluleDeb, restante As Long

Set WS1 = ThisWorkbook.Sheets("selection")
Set WS2 = ThisWorkbook.Sheets("decomposition")
max = WS1.Range("O65536").End(xlUp).Row
max2 = WS2.Range("A65536").End(xlUp).Row
Source = WS1.Range(WS1.Range("A1"), WS1.Range("Q" & max)).Value
source2 = WS2.Range(WS2.Range("A1"), WS2.Range("A" & max2)).Value

For m = 1 To max2
    l = 2
    For i = 1 To max
    k = 1
    If Source(i, 1) = Mid(source2(m, 1), 1, 2) Or Source(i, 1) = "" Then k = k + 1
    If Source(i, 2) = Mid(source2(m, 1), 3, 3) Or Source(i, 2) = "" Then k = k + 1
    If Source(i, 3) = Mid(source2(m, 1), 6, 1) Or Source(i, 3) = "" Then k = k + 1
    If Source(i, 4) = Mid(source2(m, 1), 7, 1) Or Source(i, 4) = "" Then k = k + 1
    If Source(i, 5) = Mid(source2(m, 1), 8, 2) Or Source(i, 5) = "" Then k = k + 1
    If Source(i, 6) = Mid(source2(m, 1), 10, 1) Or Source(i, 6) = "" Then k = k + 1
    If Source(i, 7) = Mid(source2(m, 1), 11, 1) Or Source(i, 7) = "" Then k = k + 1
    If Source(i, 8) = Mid(source2(m, 1), 12, 1) Or Source(i, 8) = "" Then k = k + 1
    If Source(i, 9) = Mid(source2(m, 1), 13, 1) Or Source(i, 9) = "" Then k = k + 1
    If Source(i, 10) = Mid(source2(m, 1), 14, 1) Or Source(i, 10) = "" Then k = k + 1
    If Source(i, 11) = Mid(source2(m, 1), 15, 2) Or Source(i, 11) = "" Then k = k + 1
    If Source(i, 12) = Mid(source2(m, 1), 17, 1) Or Source(i, 12) = "" Then k = k + 1
    If Source(i, 13) = Mid(source2(m, 1), 18, 1) Or Source(i, 13) = "" Then k = k + 1
    If Source(i, 14) = Mid(source2(m, 1), 19, 1) Or Source(i, 14) = "" Then k = k + 1
    If k = 15 Then
        Worksheets("decomposition").Cells(m, l).Value = Worksheets("selection").Cells(i, 17).Value
        l = l + 1
        If i = 59 Or i = 60 Then
        Worksheets("decomposition").Cells(m, 16).Value = Worksheets("selection").Cells(i, 18).Value
        End If
    End If
Next
Next
Application.ScreenUpdating = True
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 015
Membres
101 868
dernier inscrit
pierreselo33