Simplifier une macro de 15min

martinigi

XLDnaute Nouveau
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
 

Pièces jointes

  • Classeur1.xls
    15 KB · Affichages: 35

merinos

XLDnaute Accro
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?
 
Dernière édition:

merinos

XLDnaute Accro
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..;
 

thebenoit59

XLDnaute Accro
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
 

Staple1600

XLDnaute Barbatruc
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

XLDnaute Accro
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 :confused:
Tu penses que ça changerait quelque chose en exécution ?
 

thebenoit59

XLDnaute Accro
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.
 

Discussions similaires

Statistiques des forums

Discussions
311 730
Messages
2 081 989
Membres
101 856
dernier inscrit
Marina40