Simplifier une macro de 15min

martinigi · 14 Décembre 2017

Bonjour,
Je viens vers vous pour que vous m’aidiez à simplifier ma macro, je m'explique :
j'ai des feuilles excel avec environ 5000 lignes (variable) et 20 colonnes, bref il y a beaucoup de données
J'effectue une macro afin d’insérer 3 lignes vide entre chaque lignes. Mais le soucis est que la macro prend plus de 15 minutes à s'effectué.
Est ce que vous pouvez m'aider? Je vous joint un classeurs avec un exemple de données que j'utilise, les formats en fonction des ligne restent toujours les même

Code utilisé :

Sub MaMacro()

Dim I As Long
For I = [A65000] .End(xlUp).Row To 3 Step -1
Row(I).Resize(3).Insert
Next I

End Sub

Merci pour vos réponses

merinos · 14 Décembre 2017

tu ajoutes deux lignes:

VB:

Sub MaMacro()

Dim I As Long

Application.ScreenUpdating = False
For I = [A65000] .End(xlUp).Row To 3 Step -1
Row(I).Resize(3).Insert
' erreur pas ici
Next I
' mais bien ici
Application.ScreenUpdating = true
End Sub

Magique?

martinigi · 14 Décembre 2017

Noooon, j'ai l'impression que mon ordinateur et remobilisé pour 15 minute. Dsl

merinos · 14 Décembre 2017

Désolé j'ai mal positionnné l'instruction...

VB:

Sub MaMacro()

Dim I As Long

Application.ScreenUpdating = False
For I = [A65000] .End(xlUp).Row To 3 Step -1
Row(I).Resize(3).Insert
' erreur pas ici
Next I
' mais bien ici
Application.ScreenUpdating = true
End Sub

à essayer avec 200 lignes..;

martinigi · 14 Décembre 2017

C'est long, c'est très long, c'est trop long.
J'ai fait un test sur 200 lignes, ça me met beaucoup de temps (3 minutes)

thebenoit59 · 14 Décembre 2017

Bonjour Martinigi.
Bonjour Merinos.

En moins de deux secondes sur 5000 lignes :

VB:

Sub ajoutLignes()
Dim i&, ii&, j&
Dim t1(), t2()

Application.ScreenUpdating = False
t1 = Sheets(1).[A1].CurrentRegion.FormulaLocal
i = UBound(t1): j = UBound(t1, 2)
ReDim t2(1 To i * 4, 1 To j)
ii = 1
For i = LBound(t1) To UBound(t1)
    For j = LBound(t1, 2) To UBound(t1, 2)
        t2(ii, j) = t1(i, j)
    Next j
    ii = ii + 4
Next i
Sheets(1).[A1].Resize(UBound(t2), UBound(t2, 2)).FormulaLocal = t2
Application.ScreenUpdating = True
End Sub

martinigi · 14 Décembre 2017

WAW ça marche, merci boucouboucoup

Staple1600 · 14 Décembre 2017

Bonsoir le fil, le forum

Ca marche aussi (mais en plus de deux secondes et moins d'une minute)

VB:

Sub AjoutLignes()
Dim derl&, nbl&, i&: nbl = 3
Application.ScreenUpdating = False
Application.EnableEvents = False
derl = Cells(Rows.Count, "A").End(xlUp).Row
i = derl
Do While i <> 1
Rows(i & ":" & i + nbl - 1).Insert
i = i - 1
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

@thebenoit59
Pourquoi tu emploies FomulaLocal et pas Formula?
Il y a a surement un pourquoi

thebenoit59 · 14 Décembre 2017

Staple1600 à dit:
Bonsoir le fil, le forum

Ca marche aussi (mais en plus de deux secondes et moins d'une minute)

VB:

Sub AjoutLignes() Dim derl&, nbl&, i&: nbl = 3 Application.ScreenUpdating = False Application.EnableEvents = False derl = Cells(Rows.Count, "A").End(xlUp).Row i = derl Do While i <> 1 Rows(i & ":" & i + nbl - 1).Insert i = i - 1 Loop Application.ScreenUpdating = True Application.EnableEvents = True End Sub

@thebenoit59
Pourquoi tu emploies FomulaLocal et pas Formula?
Il y a a surement un pourquoi

Bonsoir Staple.

Bah en fait non il n'y a pas de raisons particulières, juste une habitude sur un de mes premiers projets où je m'emmêlais les pinceaux
Tu penses que ça changerait quelque chose en exécution ?

Staple1600 · 14 Décembre 2017

Re, Bonsoir @thebenoit59

Non je croyais que c'était un choix motivé par une raison particulière
Le seul potentiel souci que j'entrevois c'est l'utilisation de CurrentRegion.
Si jamais il y des cellules discontinues en colonne A, cela faussera la macro, non ?

thebenoit59 · 15 Décembre 2017

Staple1600 à dit:
Re, Bonsoir @thebenoit59

Non je croyais que c'était un choix motivé par une raison particulière
Le seul potentiel souci que j'entrevois c'est l'utilisation de CurrentRegion.
Si jamais il y des cellules discontinues en colonne A, cela faussera la macro, non ?

Oui tout à fait, à ce moment là il faudra déterminer les bornes pour créer le tableau virtuel comme ceci :

VB:

With Sheets(1)
    i = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    j = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    t1 = .Range(.Cells(1, 1), .Cells(i, j)).FormulaLocal
End With

Un autre souci à corriger dans ma première proposition, je n'avais pas fais attention à la retransposition des formules.
En effet, les références n'étant pas figées, il y a un décalage.
Il faut utiliser ce code :

VB:

Sub ajoutLignes2()
Dim i&, ii&, j&
Dim t1(), t2()

Application.ScreenUpdating = False

With Sheets(1)
    i = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    j = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    t1 = .Range(.Cells(1, 1), .Cells(i, j)).FormulaR1C1
End With

i = UBound(t1): j = UBound(t1, 2)
ReDim t2(1 To i * 4, 1 To j)

ii = 1
For i = LBound(t1) To UBound(t1)
    For j = LBound(t1, 2) To UBound(t1, 2)
        t2(ii, j) = t1(i, j)
    Next j
    ii = ii + 4
Next i

Sheets(1).[A1].Resize(UBound(t2), UBound(t2, 2)).FormulaR1C1 = t2

Application.ScreenUpdating = True

End Sub

Après je me demande s'il n'y a pas une méthode plus rapide pour extraire une ligne d'un array vers un autre sans boucle, ça m'intéresserait fortement pour plus d'aisance dans différentes utilisations.

Simplifier une macro de 15min

martinigi

XLDnaute Nouveau

Pièces jointes

merinos

XLDnaute Accro

martinigi

XLDnaute Nouveau

merinos

XLDnaute Accro

martinigi

XLDnaute Nouveau

thebenoit59

XLDnaute Accro

martinigi

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

thebenoit59

XLDnaute Accro

Staple1600

XLDnaute Barbatruc

thebenoit59

XLDnaute Accro

Discussions similaires