Effacer contenu cellules dont la valeur est zéro

Bonjour

Je travaille avec ce code pour effacer les cellules de la feuille "Direction" dont la valeur est égale à zéro. Toutesfois, je trouve que le code prend trop de temps pour s'exécuter et je me demandais s'il y a d'autres codes ou moyens de faire ce que je souhaite.

J'ai attaché mon fichier si cela peut aider!

Merci

Sub DeleteZeroes_Direction()

Application.EnableEvents = False
Worksheets("Direction").Activate

'Only the visible cells in the selection
Dim cell, rng As Range
Dim ls As Long
ls = Sheets("Direction").Cells(Rows.Count, "A").End(xlUp).Row

Set rng = Sheets("Direction").Range("A2:M" & ls).SpecialCells(xlCellTypeVisible)
rng.MergeCells = False

For Each cell In rng
    If cell.value = "0" Then
    cell.ClearContents
    Else
    End If
Next cell

Application.EnableEvents = True

End Sub

Bonjour,

Je n'ai pas beaucoup de propositions à vous faire, malheureusement votre tableau est assez grand et le parcourir case par case prend du temps, en plus la fonction clearcontents est "un peu lente".

Ci-après je vous joint un exemple que j'espère optimisé :

D'une part désactiver le screenupdating pour optimiser de manière générale.

D'autre part utiliser un Array, qui se parcourt plus vite qu'une range il me semble.

Utiliser Value2 qui est plus optimisé que Value.

Et enfin j'ai remarqué que votre tableau contient de nombreuses "colonnes vides", ainsi effectuer un test sur la colonne permet de la skip plus rapidement.

Sub test()
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Worksheets("Direction").Activate

  Dim cell, rng As Range
  Dim ls As Long
  ls = Worksheets("Direction").Cells(Rows.Count, "A").End(xlUp).Row

  Set rng = Worksheets("Direction").Range("B2:M" & ls).SpecialCells(xlCellTypeVisible)
  rng.MergeCells = False

  Dim arrayRng As Variant
  arrayRng = rng.Value2
  Dim val As Variant, rowIndex As Long, colIndex As Long

  For colIndex = 1 To UBound(arrayRng, 2)
    If Worksheets("Direction").Cells(2, colIndex).End(xlDown).Row = Rows.Count Then
      Range(Worksheets("Direction").Cells(3, colIndex), _
        Worksheets("Direction").Cells(UBound(arrayRng, 1), colIndex)).ClearContents
    Else
      For rowIndex = 1 To UBound(arrayRng, 1)
        If arrayRng(rowIndex, colIndex) = 0 Then
          rng(rowIndex, colIndex).ClearContents
        End If
      Next rowIndex
    End If
  Next colIndex

  Application.EnableEvents = True
  MsgBox "Nettoyage terminé"
  Application.ScreenUpdating = True
End Sub

Après je peux vous proposer certaines pistes :

Est-il nécessaire de clear contents, ou bien changer la valeur serait suffisant?

En effet il me semble qu'il est possible d'affecter les valeurs d'une array a une range rapidement, ainsi le parcours et mise à jour des valeurs de l'array, puis écriture dans Excel serait, je pense, beaucoup plus rapide. (j'ai fait le test en faisant un simple parcours de l'array avec un debug.print rowIndex, colIndex, et la boucle a pris moins d'une seconde.

Bonjour Saboh

Merci pour ton temps et proposition. Je l'ai testée et c'est encore trop long à exécuter.

Je suis en train de travailler cette approche si tu peux me guider.

Sub DeleteZeroes_Direction()

Worksheets("Direction").Activate

With Sheets("Direction").Cells(1).CurrentRegion
    .value = .value
End With

Dim LastRow As Long
LastRow = Worksheets("Direction").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("Direction").Range("A2:M" & LastRow).Replace 0, "", xlWhole

End Sub

Bonjour,

si le besoin n'est que visuel, décoche cette option :

eric