Résolu Vba lenteur macro

C

Clem69690

Nouveau membre
Bonjour à tous,
je débute en vba et j'ai créé une macro
Code: 
Sub pieceenmoule()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'vide le presse papier pour laisser plus de mémoire
Dim Cible As DataObject
Set Cible = New DataObject
Cible.SetText ""
Cible.PutInClipboard
Set Cible = Nothing
Set oDataObject = Nothing

'déclaration des variables
Dim dernligne1
Dim dernligne2

Dim i
Dim j

'trouver numéro derniere ligne / micro
dernligne1 = Sheets("Lissage Cires").Range("I27").End(xlDown).Row    'permet de trouver le numéro de la derniere ligne des micro en feuille 1
dernligne2 = Sheets("Lissage Cires (2)").Range("K9").End(xlDown).Row 'permet de trouver le numéro de la dernière ligne micro en feuille 2

'reset
Worksheets("Lissage Cires (2)").Activate
Range("K9:AX" & dernligne2).Select
Selection.ClearContents
Worksheets("Lissage Cires (2)").Activate
Range("F9:I" & dernligne2).Select
Selection.ClearContents


'copier coller les plages
'plage pièce 36semaines
Worksheets("Lissage Cires").Activate
Range("I27:AU" & dernligne1).Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("K9").Select
ActiveSheet.Paste

'plage pièce 4semaines
Worksheets("Lissage Cires").Activate
Range("D27:G" & dernligne1).Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("F9").Select
ActiveSheet.Paste

'plage jalon coef ...
Worksheets("Lissage Cires").Activate
Range("X2").Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("X2").Select
ActiveSheet.Paste

'plage H/J
Worksheets("Lissage Cires").Activate
Range("I2").Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("K2").Select
ActiveSheet.Paste

'plage couleur
Worksheets("Lissage Cires").Activate
Range("CR27:CR" & dernligne2).Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("AZ9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Worksheets("Lissage Cires").Activate
Range("DJ27:DK" & dernligne2).Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("AX9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'plage effectif+capa
Worksheets("Lissage Cires").Activate
Range("D1:G4").Select
Selection.Copy
Sheets("Lissage Cires (2)").Select
Range("F1").Select
ActiveSheet.Paste

'propager les formules colonnes ABC creuset p/g et nb moule max
    Range("A10:D" & dernligne2).FillDown
    Range("J10:J" & dernligne2).FillDown
    

    'pointeur sur les tableau pour passer chaque valeur pièce en valeur moule
    For j = 14 To 49    'trouver derniere colonne
        For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
            If Cells(i, 1).Value <> " " Then
            If Cells(i, 1).Value <> 0 Then           'repérer les erreur de saisi
                If Cells(i, j).Value <> " " Then
                If Cells(i, j).Value <> 0 Then
                    Cells(i, j).Value = Cells(i, j).Value / Cells(i, 1).Value
                Else
                    Cells(i, j).Value = " "
                End If
                Else
                    Cells(i, j).Value = " "
                End If
            Else
                Cells(i, 1).Value = " "
                If j = 14 Then
                    MsgBox ("P/G mauvais pour " & Cells(i, 11))
                End If
            End If
            Else
                Cells(i, 1).Value = " "
                If j = 14 Then
                    MsgBox ("P/G mauvais pour " & Cells(i, 11))
                End If
            End If
        Next
    Next
    
    'pointeur sur les tableau pour passer chaque valeur pièce en valeur moule
    For j = 6 To 9    'trouver derniere colonne
        For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
            If Cells(i, 1).Value <> " " Then 'repérer les erreur de saisi
                If Cells(i, j).Value <> "" Then
                If Cells(i, j).Value <> 0 Then
                    Cells(i, j).Value = Cells(i, j).Value / Cells(i, 1).Value
                Else
                    Cells(i, j).Value = ""
                End If
                Else
                    Cells(i, j).Value = ""
                End If
            End If
        Next
    Next
    
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Sub copymouleenpiece()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Cible As DataObject
Set Cible = New DataObject
Cible.SetText ""
Cible.PutInClipboard
Set Cible = Nothing


Dim dernligne1
Dim dernligne2

'trouver numéro derniere ligne / micro
dernligne1 = Sheets("Lissage Cires").Range("I27").End(xlDown).Row    'permet de trouver le numéro de la derniere ligne des micro en feuille 1
dernligne2 = Sheets("Lissage Cires (2)").Range("K9").End(xlDown).Row 'permet de trouver le numéro de la dernière ligne micro en feuille 2


'plage moule
Worksheets("Lissage Cires (2)").Activate
Range("F9:I" & dernligne2).Select
Selection.Copy
Sheets("Lissage Cires").Select
Range("D27").Select
ActiveSheet.Paste

Worksheets("Lissage Cires (2)").Activate
Range("N9:AV" & dernligne2).Select
Selection.Copy
Sheets("Lissage Cires").Select
Range("L27").Select
ActiveSheet.Paste




  
    Calculate

    Dim i
    Dim j
    Dim k
    Dim l

    For j = 12 To 47
       For i = 28 To dernligne1
                'repérer les erreur de saisi
           If Cells(i, 1).Value <> " " Then
            If Cells(i, 1).Value <> 0 Then           'repérer les erreur de saisi
                If Cells(i, j).Value <> " " Then
                If Cells(i, j).Value <> 0 Then
                    Cells(i, j).Value = Cells(i, j).Value * Cells(i, 1).Value
                Else
                    Cells(i, j).Value = " "
                End If
                Else
                    Cells(i, j).Value = " "
                End If
            Else
                Cells(i, 1).Value = " "
                If j = 12 Then
                    MsgBox ("P/G mauvais pour " & Cells(i, 9))
                End If
            End If
            Else
                Cells(i, 1).Value = " "
                If j = 12 Then
                    MsgBox ("P/G mauvais pour " & Cells(i, 9))
                End If
            End If
        Next
    Next

    For j = 4 To 7
        For i = 28 To dernligne1

            If Cells(i, 1).Value <> " " Then
                If Cells(i, j).Value <> "" Then
                If Cells(i, j).Value <> 0 Then
                    Cells(i, j).Value = Cells(i, j).Value * Cells(i, 1).Value
                Else
                    Cells(i, j).Value = ""
                End If
                Else
                    Cells(i, j).Value = ""
                End If

            End If


        Next
    Next

    
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End sub
le mystère c'est que lorsque je la lance 2/3 fois elle marche parfaitement et met 5s à se terminer mais après à partir de 4/5 lancement elle devient extrêmement longue environ de 20sec à 5-6min.
Ma question est pourquoi la macro devient plus lente au bout d'un certain nombres de lancements ?
Merci

Edit modération, merci la prochaine fois de mettre la balise code /code autour de ton programme, pour cette fois je l'ai fait à ta place.
 
drul

drul

Obscur pro du hardware
Staff
Salut,
Bon commence déjà par nettoyer ce que l'enregistreur nous a pondu stp.
Donc nettoye tout les truc du genre et reposte (avec les balises codes cette fois):
Code: 
Worksheets("Lissage Cires (2)").Activate
Range("K9:AX" & dernligne2).Select
Selection.ClearContents
'se remplace avantageusement par:
Worksheets("Lissage Cires (2)").Range("K9:AX" & dernligne2).ClearContents

Ceci est d'autant plus vrai lorsque tu utilises "copy" compacter ton code à en plus l'avantage d'éviter de remplir ton presse papier (ce qui pourrait être une cause de tes ralentissement)

Code: 
Range("A1").Select
Selection.copy
Range("A2").paste
'se remplace toujours aussi avantageusement par:
Range("A1").copy Range("A2")

P.S. :hello: zeb
 
C

Clem69690

Nouveau membre
Salut, j'ai essayé ce que tu m'as dit, d'alléger le code avec des syntaxes plus simple mais rien n'y fait le programme ralenti.
Avez vous une autre idée?
code:
Sub pieceenmoule()

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False

On Error Resume Next
Worksheets("Lissage Cires (2)").ShowAllData
Worksheets("Lissage Cires").ShowAllData

'déclaration des variables
Dim dernligne1
Dim dernligne2

Dim i
Dim j

'trouver numéro derniere ligne / micro
dernligne1 = Sheets("Lissage Cires").Range("I27").End(xlDown).Row 'permet de trouver le numéro de la derniere ligne des micro en feuille 1
dernligne2 = Sheets("Lissage Cires (2)").Range("K9").End(xlDown).Row 'permet de trouver le numéro de la dernière ligne micro en feuille 2

'reset
Worksheets("Lissage Cires (2)").Activate
Range("A11:AZ" & dernligne2).Clear

'copier coller les plages
Worksheets("Lissage Cires").Range("I27:AU" & dernligne1).Copy Destination:=Worksheets("Lissage Cires (2)").Range("K9")

'plage pièce 4semaines
Worksheets("Lissage Cires").Range("D27:G" & dernligne1).Copy Destination:=Worksheets("Lissage Cires (2)").Range("F9")

'plage jalon coef ...
Worksheets("Lissage Cires").Range("X2").Copy Destination:=Worksheets("Lissage Cires (2)").Range("Z2")

'plage H/J
Worksheets("Lissage Cires").Range("I2").Copy Destination:=Worksheets("Lissage Cires (2)").Range("K2")

'plage couleur
Worksheets("Lissage Cires").Range("CR27:CR" & dernligne1).Copy Destination:=Worksheets("Lissage Cires (2)").Range("AZ9")

Worksheets("Lissage Cires").Range("DJ27:DK" & dernligne1).Copy Destination:=Worksheets("Lissage Cires (2)").Range("AX9")

'plage effectif+capa
Worksheets("Lissage Cires").Range("D1:G4").Copy Destination:=Worksheets("Lissage Cires (2)").Range("F1")

'propager les formules colonnes ABC creuset p/g et nb moule max
Range("A10:E" & dernligne2).FillDown
Range("J10:J" & dernligne2).FillDown
Calculate

Worksheets("Lissage Cires (2)").Activate

'pointeur sur les tableau pour passer chaque valeur pièce en valeur moule
For j = 14 To 49 'trouver derniere colonne
For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
If Cells(i, 1).Value <> " " Then
If Cells(i, 1).Value <> 0 Then 'repérer les erreur de saisi
If Cells(i, j).Value <> " " Then
If Cells(i, j).Value <> 0 Then
Cells(i, j).Value = Cells(i, j).Value / Cells(i, 1).Value
Else
Cells(i, j).Value = " "
End If
Else
Cells(i, j).Value = " "
End If
Else
Cells(i, 1).Value = " "
If j = 14 Then
MsgBox ("P/G mauvais pour " & Cells(i, 11))
End If
End If
Else
Cells(i, 1).Value = " "
If j = 14 Then
MsgBox ("P/G mauvais pour " & Cells(i, 11))
End If
End If
Next
Next

'pointeur sur les tableau pour passer chaque valeur pièce en valeur moule
For j = 6 To 9 'trouver derniere colonne
For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
If Cells(i, 1).Value <> " " Then 'repérer les erreur de saisi
If Cells(i, j).Value <> "" Then
If Cells(i, j).Value <> 0 Then
Cells(i, j).Value = Cells(i, j).Value / Cells(i, 1).Value
Else
Cells(i, j).Value = ""
End If
Else
Cells(i, j).Value = ""
End If
End If
Next
Next

'pointeur sur les tableau pour passer chaque valeur pièce en valeur moule
For j = 12 To 12 'trouver derniere colonne
For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
If Cells(i, 1).Value <> " " Then 'repérer les erreur de saisi
If Cells(i, j).Value <> "" Then
If Cells(i, j).Value <> 0 Then
Cells(i, j).Value = Cells(i, j).Value / Cells(i, 1).Value
Else
Cells(i, j).Value = ""
End If
Else
Cells(i, j).Value = ""
End If
End If
Next
Next

Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 
zeb

zeb

Modérateur
Meilleure réponse
Plop,

BALISE CODE !
[:zeb:4]

Revoir l'imbrication des boucles For.
Code: 
' AVANT
For j = 14 To 49 'trouver derniere colonne
	For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
		If Cells(i, 1).Value <> " " Then
			If Cells(i, 1).Value <> 0 Then 'repérer les erreur de saisi
				If Cells(i, j).Value <> " " Then

' APRES
For i = 10 To dernligne2 'derniere ligne de la colonne I à trouver
	If Cells(i, 1).Value <> " " Then
		If Cells(i, 1).Value <> 0 Then 'repérer les erreur de saisi
			For j = 14 To 49 'trouver derniere colonne
				If Cells(i, j).Value <> " " Then
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Dernières actus
Derniers messages publiés
Statistiques globales
Discussions
730 134
Messages
6 718 070
Membres
1 586 394
Dernier membre
Manoushk
Partager cette page
Haut