Simplifier une macro de 15min

[martinigi]

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]

tu ajoutes deux lignes:

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]

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

 

[merinos]

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

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]

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]

Bonjour Martinigi.
Bonjour Merinos.

En moins de deux secondes sur 5000 lignes :

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]

WAW ça marche, merci boucouboucoup

 

[Staple1600]

Bonsoir le fil, le forum

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

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]

Bonsoir le fil, le forum

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

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]

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]

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 :

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 :

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.