Macro trop lente

Bonjour

Le code suivant efface le contenu d'une plage de cellule dans deux onglets (la plupart sont dans l'onglet "general", et une seule ligne est dans l'onglet "daily") + effectue plusieurs autres opérations.

Etant donné que l'onglet "general" se met à jour à chaque fois qu'un changement y est fait, j'ai du déverouiller l'onglet après chaque ligne d'une partie du code.

Je ne sais pas si c'est cela qui rend l'excution de la macro si lente, ou si c'est à cause de la partie qui tire vers le bas les formules et celle qui inscrit "Zéro" dans les cellules vides des colonnes C et D... Toujours étant qu'elle prend au moins 20 secondes!

Quelqu'un saurait-il comment rendre cette macro plus rapide, car pour l'instant, j'ai le temps d'aller me faire un café le temps qu'elle termine de s'exécuter.......

Sub clear_data()

'clear contents in this sheet only

msg = "Etes-vous certain(e) de vouloir ré-initialiser la rooming liste" & " " & "du groupe" & " " & Range("D1") & " " & "- hôtel:" & " " & Range("J1") & " " & "?(toutes les données seront effacées)"

Dialogstyle = vbQuestion + vbYesNo

Title = "Vérification avant effacement"

RESPONSE = MsgBox(msg, Dialogstyle, Title)

If RESPONSE = vbNo Then

msg = "Action annulée."

Exit Sub

End If

If RESPONSE = vbYes Then

End If

'CLEAR CONTENTS OF ALL CELLS WITHOUT FORMULA

ActiveSheet.Unprotect "obrat"

Range("B3:D200").ClearContents

Range("F3:G200").ClearContents

Range("I3:L200").ClearContents

Range("N3").ClearContents

Sheets("daily").Range("A4").EntireRow.ClearContents

'fill all empty cells in column D with zero

For i = 3 To 200

If IsEmpty(Range("D" & i)) Then

Range("D" & i) = 0

End If

Next

'drag formulas from all row 3 until row 200

Dim LR As Long

ActiveSheet.Unprotect "obrat"

With ActiveSheet

LR = 200

.Range("a3").AutoFill Destination:=.Range("a3:a" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

.Range("C3").AutoFill Destination:=.Range("C3:C" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

.Range("e3").AutoFill Destination:=.Range("e3:e" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

.Range("h3").AutoFill Destination:=.Range("h3:h" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

.Range("m3").AutoFill Destination:=.Range("m3:m" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

.Range("O3").AutoFill Destination:=.Range("O3:O" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

.Range("P3").AutoFill Destination:=.Range("P3:P" & LR), Type:=xlFillDefault

ActiveSheet.Unprotect "obrat"

End With

'fill all cells in column C with zero if cell in column B is empty

For i = 3 To 200

If IsEmpty(Range("B" & i)) Then

Range("C" & i) = 0

End If

Next

ActiveSheet.Range("a1").Select

ActiveSheet.Protect Password:="obrat", DrawingObjects:=False, AllowFormattingCells:=True

ActiveWorkbook.Save

End Sub

Bonjour,

Un essai à tester ...

Sinon, ça prendrait la macro de l'onglet "General"...

Aussi, penses à mettre ton code sous balises afin d'en faciliter la lecture et sa sélection ( le bouton </> en haut de la fenêtre d'écriture ) .

Sub clear_data()

   'clear contents in this sheet only

   msg = "Etes-vous certain(e) de vouloir ré-initialiser la rooming liste" & " " & "du groupe" & " " & Range("D1") & " " & "- hôtel:" & " " & Range("J1") & " " & "?(toutes les données seront effacées)"
   Dialogstyle = vbQuestion + vbYesNo
   Title = "Vérification avant effacement"
   RESPONSE = MsgBox(msg, Dialogstyle, Title)

   If RESPONSE = vbNo Then
      msg = "Action annulée."
      Exit Sub
   End If
''   If RESPONSE = vbYes Then
''   End If

   Application.ScreenUpdating = False
   Application.EnableEvents = False

   'CLEAR CONTENTS OF ALL CELLS WITHOUT FORMULA
   ActiveSheet.Unprotect "obrat"
  Range("B3:D200").ClearContents
   Range("F3:G200").ClearContents
   Range("I3:L200").ClearContents
   Range("N3").ClearContents
   Sheets("daily").Range("A4").EntireRow.ClearContents

   'fill all empty cells in column D with zero
   For i = 3 To 200
      If IsEmpty(Range("D" & i)) Then Range("D" & i) = 0
   Next

   'drag formulas from all row 3 until row 200
   Dim LR As Long
   ActiveSheet.Unprotect "obrat"

   With ActiveSheet
      LR = 200
      .Range("a3").AutoFill Destination:=.Range("a3:a" & LR), Type:=xlFillDefault
      .Range("C3").AutoFill Destination:=.Range("C3:C" & LR), Type:=xlFillDefault
      .Range("e3").AutoFill Destination:=.Range("e3:e" & LR), Type:=xlFillDefault
      .Range("h3").AutoFill Destination:=.Range("h3:h" & LR), Type:=xlFillDefault
      .Range("m3").AutoFill Destination:=.Range("m3:m" & LR), Type:=xlFillDefault
      .Range("O3").AutoFill Destination:=.Range("O3:O" & LR), Type:=xlFillDefault
      .Range("P3").AutoFill Destination:=.Range("P3:P" & LR), Type:=xlFillDefault
   End With

   'fill all cells in column C with zero if cell in column B is empty
   For i = 3 To 200
      If IsEmpty(Range("B" & i)) Then Range("C" & i) = 0
   Next

   Application.ScreenUpdating = True
   Application.EnableEvents = True

   ActiveSheet.Range("a1").Select
   ActiveSheet.Protect Password:="obrat", DrawingObjects:=False, AllowFormattingCells:=True
   ActiveWorkbook.Save

End Sub

ric

Merci!

Je vois que tu as enlevé le "unprotect" après chaque ligne.

Je l'ai mis expres car la macro bug sans ça.

A chaque fois que la macro termine d'exécuter une ligne, c'est à dire à chaque colonne qu'elle recopie vers le bas la formule de la première ligne, la macro qui protège l'onglet à chaque activation s'exécute automatiquement et donc il faut déprotéger après chaque action (chaque ligne)..

c'est en effet plus rapide donc merci !