Booster macro

[jean]

bonjour au FORUM

Je cherche a accelerer mes macros car je dois attendre 30min pour que le resultat s'affiche: c'est beaucoup trop long
il y a peut etre qqc a faire sur l'ordinateur?

merci

 

[jeromegmc]

Salut,

Je pense que tu peux déjà optimiser ton programmme, par exemple éviter d'utiliser 'select' qui ralenti le programme.

Donne des détails sur ton programme je suis sur que certains auront des solutions.

A+

 

[JEAN]

Merci de m'aider

voila les diff macros que j'utilise, elles sont toutes lancées a partir de l'ordre 1 donc d'un seul et meme bouton





Sub ordre1()
Dim u, i As Integer
Sheets('ordre1').Select
Cells.Select
Selection.Copy
Sheets('1').Select
Cells(1, 1).Select
ActiveSheet.Paste


For i = 1 To Sheets('ordre0').Range('A65000').End(xlUp).Row
For u = 1 To Sheets('1').Range('A65000').End(xlUp).Row
If Sheets('ordre0').Range('D' & i) = Sheets('1').Range('D' & u) And Sheets('ordre0').Range('H' & i) = Sheets('1').Range('H' & u) And Sheets('ordre0').Range('J' & i) = Sheets('1').Range('J' & u) And Sheets('ordre0').Range('L' & i) = Sheets('1').Range('L' & u) And Sheets('ordre0').Range('A' & i) = Sheets('1').Range('A' & u) Then
Sheets('1').Range('D' & u).Select
ActiveCell.EntireRow.Delete
End If
Next u
Next i
supprimeMoins
SelectionCopier1bis
supp
End Sub


Sub supp()
Dim i, j As Integer

Range('B4').Select

For i = Range('A65536').End(xlUp).Row To 2 Step -1
For j = 1 To (Range('IV2').End(xlToLeft).Column - 1)
If ActiveCell.Value = '***' Then
Rows(i).Delete
Cells(i, 2).Select
j = 1
k = k + 1
Else
Cells(i, j + 1).Select
End If
Next j
Cells(i - 1, 2).Select
Next i
End Sub

Option Explicit
Sub supprimeMoins()
Dim derlgn As Integer
Dim i As Integer
derlgn = Range('A65536').End(xlUp).Row
For i = 1 To derlgn
Cells(i, 10) = Replace(Cells(i, 10), '-', '', 1)
Next
End Sub

Sub SelectionCopier1bis()
Dim X, Y, Z As Integer
Application.ScreenUpdating = False
For X = 1 To 65536
If Worksheets('1').Cells(X, 6) = 'PM7' Then
Z = Worksheets('1bis').Range('A65536').End(xlUp).Row + 1
For Y = 1 To 14
Worksheets('1bis').Cells(Z, Y) = Worksheets('1').Cells(X, Y)
Next
End If
Next
Application.ScreenUpdating = True
End Sub

 

[PascalXLD]

Bonjour

Je vais essayer de te réduire le temps mais 30 minutes me parait tout de même très bizarre

Sub ordre1()
Dim u, i As Integer
Sheets('ordre1').Select
Cells.Select
Selection.Copy
Sheets('1').Select
Cells(1, 1).Select
ActiveSheet.Paste


For i = 1 To Sheets('ordre0').Range('A65000').End(xlUp).Row
For u = 1 To Sheets('1').Range('A65000').End(xlUp).Row
If Sheets('ordre0').Range('D' & i) = Sheets('1').Range('D' & u) And Sheets('ordre0').Range('H' & i) = Sheets('1').Range('H' & u) And Sheets('ordre0').Range('J' & i) = Sheets('1').Range('J' & u) And Sheets('ordre0').Range('L' & i) = Sheets('1').Range('L' & u) And Sheets('ordre0').Range('A' & i) = Sheets('1').Range('A' & u) Then
Sheets('1').Rows(u).Delete ' là je suis pas trop sur regarde
End If
Next u
Next i
supprimeMoins
SelectionCopier1bis
supp
End Sub


Sub supp() ' Cette macro qui select beaucoup doit prendre beaucoup de temps mais il faudrait voir exactement ce qu'elle fait pour eviter le select
Dim i, j As Integer

Range('B4').Select

For i = Range('A65536').End(xlUp).Row To 2 Step -1
For j = 1 To (Range('IV2').End(xlToLeft).Column - 1)
If ActiveCell.Value = '***' Then
Rows(i).Delete
Cells(i, 2).Select
j = 1
k = k + 1
Else
Cells(i, j + 1).Select
End If
Next j
Cells(i - 1, 2).Select
Next i
End Sub

Option Explicit
Sub supprimeMoins()
Dim derlgn As Integer
Dim i As Integer
derlgn = Range('A65536').End(xlUp).Row
For i = 1 To derlgn
Cells(i, 10) = Replace(Cells(i, 10), '-', '', 1)
Next
End Sub

Sub SelectionCopier1bis()
Dim X, Y, Z As Integer
Dim derlgn As Integer
Application.ScreenUpdating = False
derlgn = Worksheets('1').Range('A65536').End(xlUp).Row 'ICI pour eviter de boucler sur les 65536 lignes
For X = 1 To derlgn
If Worksheets('1').Cells(X, 6) = 'PM7' Then
Z = Worksheets('1bis').Range('A65536').End(xlUp).Row + 1

Worksheets('1bis').range(Cells(Z, 1),cells(Z,14)) = Worksheets('1').range(Cells(X, 1),cells(X,14)) 'Et là aussi essaies sans boucle

End If
Next
Application.ScreenUpdating = True
End Sub

Message édité par: Pascal76, à: 29/06/2005 12:18

 

[jean]

merci je vais essayer

 

[Hervé]

BOnjour jean, jerome, pascal, le forum

Meme constatation que pascal, voir si le code suivant n'accélère pas le traitement :

Sub supp()
dim i as integer
dim j as integer

For i = Range('A65536').End(xlUp).Row To 2 Step -1
For j = 1 To Cells(i, 256).End(xlToLeft).Column
If Cells(i, j) = '***' Then Rows(i).Delete
Next j
Next i
End Sub

A suivre...

salut

Edition : tu travailles sur combien de ligne en moyenne jean ?

Message édité par: Hervé, à: 29/06/2005 12:31

 

[jean]

bonjour

en fait c'est cette macro qui me pose probleme car si je la lance toute seule et je lui demande de comparer 2 feuilles de 3000 lignes (et 12 colones)chacunes elle met 30 min voir plus pour afficher le resultat.
mon ordinateur est un P4 1500


Sub ordre1()
Dim u, i As Integer
Sheets('ordre1').Select
Cells.Select
Selection.Copy
Sheets('1').Select
Cells(1, 1).Select
ActiveSheet.Paste


For i = 1 To Sheets('ordre0').Range('A65000').End(xlUp).Row
For u = 1 To Sheets('1').Range('A65000').End(xlUp).Row
If Sheets('ordre0').Range('D' & i) = Sheets('1').Range('D' & u) And Sheets('ordre0').Range('H' & i) = Sheets('1').Range('H' & u) And Sheets('ordre0').Range('J' & i) = Sheets('1').Range('J' & u) And Sheets('ordre0').Range('L' & i) = Sheets('1').Range('L' & u) And Sheets('ordre0').Range('A' & i) = Sheets('1').Range('A' & u) Then
Sheets('1').Range('D' & u).Select
ActiveCell.EntireRow.Delete
End If
Next u
Next i

End Sub

 

[PascalXLD]

Pour gagner beaucoup de temps il faudrait mettre toutes tes données dans une variable tableau faire le test sur cette variable et tout remettre sur tes feuilles

Mais bon il va falloir un peu de temps pour le faire

 

[PascalXLD]

re

Bon j'ai un peu de mal car là le but n'est pas de mettre des données mais d'en retirer

Bon j'ai biaisé et je te donne ceci mais
1 - je n'ai pas testé
2 - je pense qu'on peut mieux faire

Sub ordre2()
Dim MonTableauSource As Variant
Dim MonTableauSource2 As Variant
Dim MonTableauCible()
Dim MaLigne As Integer
Dim x As Integer, y As Integer, z As Byte, i As Byte
Dim verif As Boolean

MaLigne = Worksheets('ordre0').Range('A65536').End(xlUp).Row


MonTableauSource = Worksheets('ordre0').Range(Cells(1, 1), Cells(MaLigne, 12))

MaLigne = Worksheets('ordre1').Range('A65536').End(xlUp).Row

z = 0
MonTableauSource2 = Worksheets('ordre1').Range(Cells(1, 1), Cells(MaLigne, 12))

For x = 1 To UBound(MonTableauSource)
For y = 1 To UBound(MonTableauSource2)
If MonTableauSource(x, 1) = MonTableauSource2(y, 1) And MonTableauSource(x, 4) = MonTableauSource2(y, 4) And MonTableauSource(x, 8) = MonTableauSource2(y, 8) And MonTableauSource(x, 10) = MonTableauSource2(y, 10) And MonTableauSource(x, 12) = MonTableauSource2(y, 12) Then
z = z + 1
ReDim Preserve MonTableauCible(z)
MonTableauCible(z) = y
Next y
Next x
MaLigne = 1
For y = 1 To UBound(MonTableauSource2)
verif = True
For x = 1 To z
If MonTableauCible(x) = y Then
verif = False
Exit For
End If
Next x
If verif = True Then
For i = 1 To 12
Sheets('1').Cells(MaLigne, i) = MonTableauSource2(y, i)
MaLigne=Maligne + 1
Next i
Next y

End Sub


Edition : Peut-on faire un genre removeitem sue un tableau de variable ? Voilà une question dont je ne trouve pas de réponse

Message édité par: Pascal76, à: 30/06/2005 12:24

 

[jean]

merci pascal

ta macro me parait tres bien mais je croix qu'il ya un probleme en ce qui concerne les For et next la macro ne veut pas fonctioner

peux tu encore m'aider?

 

[PascalXLD]

Re

elle bug où ??

tu as remarqué que j'ai changé le nom au cas où tu ais fait un copier-coller ??

 

[jean]

oui j'ai remarqué elle beug a partir de

Next y
Next x
MaLigne = 1
For y = 1 To UBound(MonTableauSource2)
verif = True
For x = 1 To z
If MonTableauCible(x) = y Then
verif = False
Exit For
End If
Next x
If verif = True Then
For i = 1 To 12
Sheets('1').Cells(MaLigne, i) = MonTableauSource2(y, i)
Next i
Next y

End Sub

 

[PascalXLD]

et quel est le message d'erreur ???

 

[jean]

re,

le message d'erreur indique 'next sans for'

 

[PascalXLD]

oups j'ai oublié un end if à la fin

If verif = True Then
For i = 1 To 12
Sheets('1').Cells(MaLigne, i) = MonTableauSource2(y, i)
Next i
End if 'ICI
Next y

End Sub