Autres Optimisation de macro

Muratime

XLDnaute Junior
Bonjour forum, ;)
J'ai deux macros dans mon fichier une qui s'appel "supprimerlignes" et l'autre "rangementfeuille" et je voudrais les optimiser car la première macro met 7 minutes 40 pour faire le job et l'autre 30 secondes ce qui est mieux. Ce qui fait un total de plus de 8 minutes pour ranger 8475 lignes, je pense quelles peuvent faire mieux.
Merci de votre aide
 

Pièces jointes

  • test1.xlsm
    124.3 KB · Affichages: 12
Solution
Re

Alors il faut d'abord ajouter une feuille que tu nommeras RESULTAT
Ensuite tu renommes la feuille où sont tes données en TEST
Puis tu lances la macro Traiter_Feuille
Et ensuite tu vas voir le résultat (je te le donne en mille ;)), sur la feuille RESULTAT
VB:
Sub Traiter_Feuille()
Application.ScreenUpdating = False
supprimer
ranger
End Sub
Private Sub supprimer()
Dim derniereLigne&, i&, vArr, F As Worksheet: Set F = Sheets("TEST")
derniereLigne = F.Range("A" & Rows.Count).End(xlUp).Row
For i = derniereLigne To 1 Step -1
If VBA.Trim(F.Cells(i, 1)) Like "NS" Then
vArr = F.Cells(i, 1).Offset(1).Resize(18).Value2
F.Cells(i, "C").Resize(, 18).Value = Application.Transpose(vArr)
End If
Next
F.Columns("A:B").Delete...

Staple1600

XLDnaute Barbatruc
Re

Est-ce qu'on se rapproche du résultat souhaité?
VB:
Sub Traiter_Feuille()
Application.ScreenUpdating = False
supprimer
ranger
Cells(1).CurrentRegion.Columns.AutoFit
End Sub
Private Sub supprimer()
Dim derniereLigne&, i&, j&, vArr
derniereLigne = Range("A" & Rows.Count).End(xlUp).Row
j = 1
For i = derniereLigne To 1 Step -1
If VBA.Trim(Cells(i, 1)) Like "NS" Then
vArr = Cells(i, 1).Offset(1).Resize(15).Value2
Cells(j, "C").Resize(, 15).Value = Application.Transpose(vArr)
End If
j = j + 1
Next
End Sub
Private Sub ranger()
Columns("A:B").Delete
With ActiveSheet.UsedRange
    .Sort .Columns(1), xlAscending, Header:=xlNo 'tri sur 3 colonnes
End With
Rows("1:16").EntireRow.Delete
End Sub
Lancer la macro nommée: Traiter_Feuille
 

Staple1600

XLDnaute Barbatruc
Re

Et comme ceci?
VB:
Sub Traiter_Feuille()
Application.ScreenUpdating = False
supprimer
ranger
Cells(1).CurrentRegion.Columns.AutoFit
End Sub
Private Sub supprimer()
Dim derniereLigne&, i&, j&, vArr
derniereLigne = Range("A" & Rows.Count).End(xlUp).Row
j = 1
For i = derniereLigne To 1 Step -1
If VBA.Trim(Cells(i, 1)) Like "NS" Then
vArr = Cells(i, 1).Offset(1).Resize(18).Value2
Cells(j, "C").Resize(, 18).Value = Application.Transpose(vArr)
End If
j = j + 1
Next
End Sub
Private Sub ranger()
Columns("A:B").Delete
With ActiveSheet.UsedRange
    .Sort .Columns(1), xlAscending, Header:=xlNo 'tri sur 3 colonnes
End With
Rows("1:16").EntireRow.Delete
End Sub
 

Discussions similaires

Réponses
18
Affichages
803

Statistiques des forums

Discussions
311 720
Messages
2 081 926
Membres
101 842
dernier inscrit
seb0390