Accélérer exécution

[Micka2305]

Bonjour, la macro suivante fonctionne très bien mais elle met environ 30 secondes à s'exécuter.
Auriez vous une idée pour accélérer son exécution?

En vous remerciant,
Mickael

Sub validerbondenlevement()

Dim Rep As Integer


Rep = MsgBox("Voulez vous vraiment valider et envoyer le " & Range("D3") & "?", vbYesNo + vbQuestion, "Attention")


If Rep = vbYes Then
ActiveSheet.Unprotect

If Range("D7").Value <> 0 Then
If Range("F7").Value <> 0 Then

derlig = Sheets("bon de livraison").Cells(Cells.Rows.Count, "D").End(xlUp).Row
derligstock = Sheets("Stock").Cells(Cells.Rows.Count, "E").End(xlUp).Row
derligjourn = Sheets("Journal de bord").Cells(Cells.Rows.Count, "A").End(xlUp).Row

' Sortie ====> Stock

'je parcours les lignes des entr_es
For Each c In Sheets("bon de livraison").Range("D1352" & derlig)

'je parcours les lignes des stocks
For Each d In Sheets("Stock").Range("E2:E" & derligstock)
'si article stock = article entr_e alors
If c = d Then
'valeur stock + valeur entr_e
d.Offset(0, 6) = d.Offset(0, 6) + c.Offset(0, 1)
End If
Next
Next


' Sortie ====> Journal
derligjourn = derligjourn + 1
'je parcours les lignes des sorties
For Each c In Range("C13:C52")
'je m'assure que la sortie n'est pas vide pour eviter une insertion d'une ligne vide
If c <> 0 Then
'je saisie que c'est une sortie
Sheets("Journal de bord").Range("A" & derligjourn).Value = "Sortie"
Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 1) = Sheets("bon de livraison").Range("D7")
Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 2) = Sheets("bon de livraison").Range("F7")
'je saisie la designation
Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 3) = c.Offset(0, 1)
Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 4) = c.Offset(0, 2)
Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 5) = c.Offset(0, 4)
'je saisie la quantit_

'je saisie la date
Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 6) = Date
'j'incremente le numero de ma derniere ligne
derligjourn = derligjourn + 1
End If
Next


Range("C13:C52").ClearContents






MsgBox "Bon de livraison validé. Le stock est actualisé."




Else
MsgBox ("Attention: veuilez entrer le nom du client/chantier avant de valider")
End If
Else
MsgBox ("Attention: sélectionner votre nom avant de valider")
End If
End If

 

[pierrejean]

bonjour Micka
Une copie de ton fichier réduit aux éléments indispensables et avec quelques lignes 'bidon' nous aiderait à t'aider !!!

 

[Micka2305]

Bonjour Pierre-Jean,

Tout d'abord merci pour votre intérêt.
Ensuite voici un lien du fichier concerné: www.grosfichiers.com/yzVY5cRUReN

Merci

 

[pierrejean]

Re

A tester:

Sub envoyerpdfmail()
 
    Dim Rep As Integer
    

     Rep = MsgBox("Voulez vous vraiment valider et envoyer le " & Range("D3") & "?", vbYesNo + vbQuestion, "Attention")
    
    
     If Rep = vbYes Then
     ActiveSheet.Unprotect
  
     If Range("D7").Value <> 0 Then
     If Range("F7").Value <> 0 Then

    derlig = Sheets("bon de livraison").Cells(Cells.Rows.Count, "D").End(xlUp).Row
    derligstock = Sheets("Stock").Cells(Cells.Rows.Count, "E").End(xlUp).Row
    derligjourn = Sheets("Journal de bord").Cells(Cells.Rows.Count, "A").End(xlUp).Row

    ' Sortie ====> Stock


    For Each c In Sheets("bon de livraison").Range("D13:D" & derlig)
       If c <> " " Then

        Set d = Sheets("Stock").Columns("E").Find(c, LookIn:=xlValues, lookat:=xlWhole)
        If Not d Is Nothing Then
            d.Offset(0, 6) = d.Offset(0, 6) + c.Offset(0, 1)
        End If
     End If
    Next


    ' Sortie ====> Journal
    derligjourn = derligjourn + 1
    'je parcours les lignes des sorties
    For Each c In Range("C13:C52")
        'je m'assure que la sortie n'est pas vide pour eviter une insertion d'une ligne vide
        If c <> 0 Then
            'je saisie que c'est une sortie
            Sheets("Journal de bord").Range("A" & derligjourn).Value = "Sortie"
            Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 1) = Sheets("bon de livraison").Range("D7")
            Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 2) = Sheets("bon de livraison").Range("F7")
            'je saisie la designation
            Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 3) = c.Offset(0, 1)
            Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 4) = c.Offset(0, 2)
            Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 5) = c.Offset(0, 4)
            'je saisie la quantit_
 
            'je saisie la date
            Sheets("Journal de bord").Range("A" & derligjourn).Offset(0, 6) = Date
            'j'incremente le numero de ma derniere ligne
            derligjourn = derligjourn + 1
        End If
    Next


   Range("C13:C52").ClearContents
        
        
    



    MsgBox "Bon de livraison validŽ. Le stock est actualisŽ."



  
Else
MsgBox ("Attention: veuilez entrer le nom du client/chantier avant de valider")
End If
Else
MsgBox ("Attention: sŽlectionner votre nom avant de valider")
End If
End If
ActiveSheet.Protect
End Sub

 

[Micka2305]

Bonsoir,
Merci énormément c'est super !!!

Pourriez vous m'aider à nouveau sur ce fichier?
Lorque je rentre une référence sur le bon d'enlèvement (dans la cellule prévue à cette effet) la quantité s'affiche bien. Cependant lorsque je rentre à nouveau la même référence, les quantités au lieu de s'ajouter s'écrive à coté (exemple: 1010 avec un colisage de 10).

En vous remerciant,
Mickael

 

[pierrejean]

Re
Je ne constate pas ce phénomène
Toutefois essayer
remplacer
If bb Then 'Existe dans le bon de livraison (Existe forcŽment dans le stock)
Set e = Sheets("stock").Columns(2).Find(target.Value, LookIn:=xlValues, lookat:=xlWhole)
b.Offset(, 2) = b.Offset(, 2) + e.Offset(, 5)
par
If bb Then 'Existe dans le bon de livraison (Existe forcŽment dans le stock)
Set e = Sheets("stock").Columns(2).Find(target.Value, LookIn:=xlValues, lookat:=xlWhole)
b.Offset(, 2) = b.Offset(, 2) * 1 + e.Offset(, 5) * 1
Si pas de résultat me préciser un exemple de saisie provoquant cette erreur

 

[Micka2305]

Astuce parfaite ça marche impeccable.
Vous m'avez fait gagner énormément de temps.
Un grand merci!