Problème de temps de calcul dans une macro

Bonjour.
Si tu postais ton code ?
Cordialement.
Daniel
"Lycaon" <tristan.pochat@gmail.com> a écrit dans le message de news:
1163412383.426300.318520@b28g2000cwb.googlegroups.com...
Bonjour à tous,

J'ai un problème dans l'une de mes macros.
Elle réalise une fonction d'insertion de lignes dans un fichier. En
fonction de certains critères, elle insère (ou pas) une ligne en
première position dans le fichier "Final.xls".
Or, quand le fichier "Final.xls" devient assez important (pas tant que
ça : 280 lignes), il met un temps notable à insérer la ligne (de
l'ordre de la seconde !!!).

A quoi cela est il dû ? Et comment le résoudre ?

Merci pour votre aide,

Lycaon

Ce code est perdu au milieu d'une macro beaucoup plus vaste. Toutes les
variables sont définies...

For j = 1 To Der
On Error Resume Next
Range("A" & j).Select
'On regarde si les projets possèdent des numéros de référence
Select Case Left(ActiveCell.Value, 3)
'Si le projet a déjà un numéro de référence ou si il complète un
projet déjà existant, on copie la ligne
Case IsNumeric(Left(LTrim(ActiveCell.Value), 3)) = True, Is =
"NEW", Is = "new", Is = "New"
Range("A" & j).EntireRow.Select
Selection.Copy
With Workbooks(NomClasseur).Sheets(1).Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
With Selection.Insert
End With
End With

ActiveWindow.ActivatePrevious
'Si c'est un nouveau projet, on copie la ligne en mettant "Totally New"
dans la case Ref Number
Case Else
On Error Resume Next
Range("A" & j).EntireRow.Select
Selection.Copy
With Workbooks(NomClasseur).Sheets(1).Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
With Selection.Insert
End With
End With
ActiveCell.Value = "Totally New"
ActiveWindow.ActivatePrevious

End Select
Next

Voili, voilou,

Merci à tous,

Lycaon

Essaie ceci ... en supposant que je n'ai pas changé la nature de ta procédure...


'--------------------------------------
Sub test()

Dim J As Long, T As String
Dim Der As Long
Der = 1 'à déterminer

Application.EnableEvents = False
Application.ScreenUpdating = False

With Worksheets("NomFeuillePLageSource") 'à déterminer
On Error Resume Next
For J = 1 To Der
T = UCase(Left(LTrim(.Range("A" & J).Value), 3))
Select Case T
Case True, "NEW"
.Range("A" & J).EntireRow.Copy
With Workbooks(NomClasseur).Sheets(1)
.Range("A1").End(xlDown).Offset(1, 0).Insert
End With
Case Else
.Range("A" & J).EntireRow.Copy
With Workbooks(NomClasseur).Sheets(1)
.Range("A1").End(xlDown).Offset(1, 0).Insert
End With
.Range("A" & J) = "Totally New"
End Select
Next
End With
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
'--------------------------------------



"Lycaon" <tristan.pochat@gmail.com> a écrit dans le message de news:
1163414173.131069.27130@f16g2000cwb.googlegroups.com...
Ce code est perdu au milieu d'une macro beaucoup plus vaste. Toutes les
variables sont définies...

For j = 1 To Der
On Error Resume Next
Range("A" & j).Select
'On regarde si les projets possèdent des numéros de référence
Select Case Left(ActiveCell.Value, 3)
'Si le projet a déjà un numéro de référence ou si il complète un
projet déjà existant, on copie la ligne
Case IsNumeric(Left(LTrim(ActiveCell.Value), 3)) = True, Is "NEW", Is = "new", Is = "New"
Range("A" & j).EntireRow.Select
Selection.Copy
With Workbooks(NomClasseur).Sheets(1).Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
With Selection.Insert
End With
End With

ActiveWindow.ActivatePrevious
'Si c'est un nouveau projet, on copie la ligne en mettant "Totally New"
dans la case Ref Number
Case Else
On Error Resume Next
Range("A" & j).EntireRow.Select
Selection.Copy
With Workbooks(NomClasseur).Sheets(1).Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
With Selection.Insert
End With
End With
ActiveCell.Value = "Totally New"
ActiveWindow.ActivatePrevious

End Select
Next

Voili, voilou,

Merci à tous,

Lycaon

Tu dois modifier cette ligne de code dans ta procédure:
Case True, "NEW"

Par : Case IsNumeric(t), "NEW"


'--------------------------------------
Sub test()

Dim J As Long, T As String
Dim Der As Long
Der = 1 'à déterminer

Application.EnableEvents = False
Application.ScreenUpdating = False

With Worksheets("NomFeuillePLageSource") 'à déterminer
On Error Resume Next
For J = 1 To Der
T = UCase(Left(LTrim(.Range("A" & J).Value), 3))
Select Case T
Case IsNumeric(T), "NEW"
.Range("A" & J).EntireRow.Copy
With Workbooks(NomClasseur).Sheets(1)
.Range("A1").End(xlDown).Offset(1, 0).Insert
End With
Case Else
.Range("A" & J).EntireRow.Copy
With Workbooks(NomClasseur).Sheets(1)
.Range("A1").End(xlDown).Offset(1, 0).Insert
End With
.Range("A" & J) = "Totally New"
End Select
Next
End With
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
'--------------------------------------



"Lycaon" <tristan.pochat@gmail.com> a écrit dans le message de news:
1163414173.131069.27130@f16g2000cwb.googlegroups.com...
Ce code est perdu au milieu d'une macro beaucoup plus vaste. Toutes les
variables sont définies...

For j = 1 To Der
On Error Resume Next
Range("A" & j).Select
'On regarde si les projets possèdent des numéros de référence
Select Case Left(ActiveCell.Value, 3)
'Si le projet a déjà un numéro de référence ou si il complète un
projet déjà existant, on copie la ligne
Case IsNumeric(Left(LTrim(ActiveCell.Value), 3)) = True, Is "NEW", Is = "new", Is = "New"
Range("A" & j).EntireRow.Select
Selection.Copy
With Workbooks(NomClasseur).Sheets(1).Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
With Selection.Insert
End With
End With

ActiveWindow.ActivatePrevious
'Si c'est un nouveau projet, on copie la ligne en mettant "Totally New"
dans la case Ref Number
Case Else
On Error Resume Next
Range("A" & j).EntireRow.Select
Selection.Copy
With Workbooks(NomClasseur).Sheets(1).Activate
Range("A1").End(xlDown).Offset(1, 0).Activate
With Selection.Insert
End With
End With
ActiveCell.Value = "Totally New"
ActiveWindow.ActivatePrevious

End Select
Next

Voili, voilou,

Merci à tous,

Lycaon