améliorer la vitesse d'une macro

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
K

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: 122
  • Sans titre.jpg
    Sans titre.jpg
    48 KB · Affichages: 131
Trier par date Trier par votes
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 😡 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

Dernière édition:
Vote positif 0 Vote négatif
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: 101
  • Sans titre.jpg
    Sans titre.jpg
    28.6 KB · Affichages: 100
Vote positif 0 Vote négatif
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

Dernière édition:
Vote positif 0 Vote négatif
Re : améliorer la vitesse d'une macro

Bonsoir kevenpom 🙂 ,
kevenpom à dit:
(...) 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.(...)
Cliquez pour agrandir...

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

A+
 
Vote positif 0 Vote négatif
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
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
617
KRUG WOO
K
F
  • Résolu(e)
Autres Insérer une ligne
2 3
Réponses
36
Affichages
3 K
francescofrancesco
F
A
  • Question Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
520
Phil69970
Phil69970
ARaul
  • Question Question
XL 2019 Erreur d'exécution "13"
Réponses
1
Affichages
295
sylvanu
sylvanu
Regueiro
  • Question Question
Microsoft 365 VBA Transpose
Réponses
11
Affichages
867
sylvanu
sylvanu
F
  • Question Question
XL 2021 probleme dans la macro
Réponses
4
Affichages
574
kiki29
kiki29
F
  • Question Question
Microsoft 365 Problème mémoire insuffisante
Réponses
5
Affichages
700
TooFatBoy
TooFatBoy
S
  • Question Question
XL 2021 Listing Album Panini
Réponses
5
Affichages
474
job75
job75
D
  • Question Question
XL 2019 VBA Définir une zone d'impression
Réponses
5
Affichages
403
dadaze
D
N
  • Question Question
Listbox click
Réponses
10
Affichages
525
ChTi160
ChTi160
U
  • Question Question
Autres [RÉSOLU] macro à modifier
Réponses
1
Affichages
507
un internaute
U
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
955
tnion
T
B
  • Question Question
Autres Problème d'adaptation du contenu d'une listbox
Réponses
7
Affichages
447
jurassic pork
jurassic pork
N
  • Question Question
Microsoft 365 gestion de kilometrage
Réponses
4
Affichages
240
nabilexcel2007
N
J
  • Question Question
Microsoft 365 Userform comboboxes indexés
Réponses
8
Affichages
269
jp26200
J
A
  • Question Question
XL 2019 Copie d'une valeur dans la cellule à côté d'une valeur trouvé
Réponses
1
Affichages
448
sylvanu
sylvanu
M
  • Résolu(e)
Microsoft 365 Trouver une valeur dans une colonne
Réponses
7
Affichages
224
mikeduff
M
A
  • Question Question
XL 2010 Filtrer un Combobox en VBA excel
2 3
Réponses
43
Affichages
2 K
Dranreb
Dranreb
W
  • Résolu(e)
XL 2016 Placer mes photos dans la colonne A, [A3], [A4],etc, jusqu'en [A99] selon le prénom et le nom colonnes B et C
2
Réponses
26
Affichages
1 K
Webperegrino
W
M
  • Résolu(e)
XL 2021 Problème d'activation d'une macro pour transférer des valeurs d'une feuille 1 à une feuille 2
Réponses
3
Affichages
153
MATLEA
M
Retour