XL 2010 Bug Macro affecte image à listes déroulantes

riton00 à dit:

Bonsoir, à tous

Bizarre chez moi ça marche

Slts

Cliquez pour agrandir...

sylvanu à dit:

Sur 2007 c'est totalement aléatoire, mais il ne va jamais jusqu'à la fin.

Cliquez pour agrandir...

sylvanu à dit:

Re,
Exact, ça rame un peu. Mais on trouve toujours une solution même si elle est vraiment bancale.
En insistant un peu, certains DoEvents ont été supprimés en accélérant le process avec un figeage écran:

Code:

Sub AffecteFlèche()
Application.ScreenUpdating = False
For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
   ActiveSheet.Shapes("fleche1").Copy
   c.Offset(, 1).Select
    DoEvents
    ActiveSheet.Paste
    DoEvents
    With Selection
        .Name = c.Address
        .Left = c.Offset(, 1).Left
        .Top = c.Offset(, 1).Top + 1
        .Height = c.Offset(, 1).Height
        .OnAction = "clicFlèche"
    End With
Next c
End Sub

Cliquez pour agrandir...

mapomme à dit:

Re @sylvanu

Pour 1000 cellules, entre 0.47 et 0.60 secondes en 2010.

VB:

Sub AffecteFlèche()
Dim arr As Shape, T0
   T0 = Timer
   Application.ScreenUpdating = False
   For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
      Set arr = ActiveSheet.Shapes("fleche1").Duplicate
      With c.Offset(, 1)
         arr.Name = c.Address
         arr.Left = .Left
         arr.Top = .Top + 1
         arr.Height = .Height
         arr.OnAction = "clicFlèche"
      End With
   Next c
   MsgBox Format(Timer - T0, "0.00\ sec.")
End Sub

Cliquez pour agrandir...

mapomme à dit:

Re @sylvanu

Pour 1000 cellules, entre 0.47 et 0.60 secondes en 2010.

VB:

Sub AffecteFlèche()
Dim arr As Shape, T0
   T0 = Timer
   Application.ScreenUpdating = False
   For Each c In Cells.SpecialCells(xlCellTypeAllValidation)
      Set arr = ActiveSheet.Shapes("fleche1").Duplicate
      With c.Offset(, 1)
         arr.Name = c.Address
         arr.Left = .Left
         arr.Top = .Top + 1
         arr.Height = .Height
         arr.OnAction = "clicFlèche"
      End With
   Next c
   MsgBox Format(Timer - T0, "0.00\ sec.")
End Sub

Cliquez pour agrandir...