XL 2010 Bug Macro affecte image à listes déroulantes

[Orson83]

Bonjour la communauté,
J'ai un bug dans une macro qui permet de générer des images "flèche" à chaque liste déroulante.
En effet, toutes les flèches ne sont pas attribuées à mes listes et j'ai une erreur d'exécution 1004.
Merci pour votre aide. Mon exemple est annexé.
Tchotchodu31

 

[riton00]

Bonsoir, à tous

Bizarre chez moi ça marche

Slts

 

[Orson83]

Bonsoir, à tous

Bizarre chez moi ça marche

Slts

Chez moi c'est aléatoire mais les flèches ne s'insèrent jamais jusqu'à la 96ème ligne.
Si quelqu’un peu m'aider svp ?
Merci.

 

[riton00]

Re bonsoir

J'ai testé cette macro sur 450 liste déroulante, ça marche sans problème et même assez rapidement

Slts

 

[mapomme]

Bonjour @Tchotchodu31, @riton00

Chez moi (2010) ça marche impeccablement.

Ce qui m'interroge surtout, c'est pourquoi faire tant de choses bizarres en VBA alors qu'il existe déjà la flèche des liste de validations ?

C'est chercher des ennuis. Et à priori, on les a trouvés .

 

[sylvanu]

Bonsoir Tchotchodu31, Riton, MaPomme,
Sur 2007 c'est totalement aléatoire, mais il ne va jamais jusqu'à la fin.
Une piste peut être : si je mets un point d'arrêt sur Next c et que je boucle à la main alors ça marche impeccable.
Par contre pas de solution.
Un truc qui marche juste pour tester, mettre des DoEvents partout. par contre il faut que je les double. c'est vraiment bizarre. Comme si quand il faisait le paste, le paste précédent n'était pas terminé.

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

 

[mapomme]

bonsoir @sylvanu

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

Quand j'ai eu 2007, j'ai failli passer au logiciel libre
La gestion des formes et autres n'était vraiment pas au point.

 

[sylvanu]

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:

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

 

[mapomme]

Re @sylvanu

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

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

 

[Orson83]

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:

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

Merci Sylvanu, cette macro fonctionne parfaitement.
Effectivement, je pense que la macro initiale posait problème avec Excel 2010.
Bonne soirée.
François

 

[Orson83]

Re @sylvanu

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

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

Merci Sylvanu, cette macro fonctionne parfaitement.
Effectivement, je pense que la macro initiale posait problème avec Excel 2010.
Bonne soirée.
François

Re @sylvanu

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

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

Merci mapomme, cette macro fonctionne parfaitement.
Effectivement, je pense que la macro initiale posait problème avec Excel 2010.
Bonne soirée.
François