Barre de progression ne bouge pas

Bonjour,

je tente de faire une barre de progression avec 2 formes (rectangle 1 et rectangle 2)
Lorsque j'utilise ce type de code sur mon pc professionnel je vois bien la barre de progression évoluer de manière fluide. Sur mon pc privé malheureusement la barre de progression n'évolue pas durant les 20 secondes d'éxecution de la macro et elle se met à jour uniquement une fois que la macro est terminée (par contre j'entends le pc qui travail). Pouvez-vous me dire si je peux effectuer quelques changement de paramétrage du pc pour optimiser ses performances ? ou peut-être le problème vient-il de la macro ? voici le code :

Sub test()
Set Rect = ActiveSheet.Shapes("Rectangle 1")
Set ProgBar = ActiveSheet.Shapes("Rectangle 2")
With ProgBar
    .Width = Rect.Width
    .Left = Rect.Left
    .Top = Rect.Top
    .Height = Rect.Height
End With
t = Timer
a = 0
Do Until (Timer - t) > 20
    ProgBar.Width = Rect.Width - (Timer - t)
    DoEvents
Loop
End Sub

petite précision, si j'exécute le code en mode débogage ligne par ligne la barre de progression évolue bel et bien à chaque passage sur la ligne "ProgBar.Width = Rect.Width - (Timer-t).
enfin, mon pc privé possède 32Go de RAM, un processeurn i7 9th gen et une carte graphique nvidia geforce gtx 16 series.

Merci pour votre aide ! :)

Sub test()
Set Rect = ActiveSheet.Shapes("Rectangle 1")
Set ProgBar = ActiveSheet.Shapes("Rectangle 2")
With ProgBar
    .Width = Rect.Width
    .Left = Rect.Left
    .Top = Rect.Top
    .Height = Rect.Height
End With
t = Timer
a = 0
Do Until (Timer - t) > 20
    ProgBar.Width = Rect.Width - (Timer - t)
    DoEvents
    Calculate
Loop
End Sub

Rebonjour,

pour info j'ai rajouté "calculate" et celà semble mieux fonctionner. Je laisse le poste ouvert pour avoir d'autres propositions mais voici le code adapté :

bonjour Lorenzoforte,

je déteste l'idée d'une barre de progression, il faut chercher à augmenter la vitesse de la macro, au lieu de la ralentir avec cette barre.

Vous pouvez doubler le nombre de "DoEvents" et minimaliser le nombre de "updates", par exemple seulement 20 (=chaque 5%, = évoluer moins "fluide")

Sub test()
     Dim dWidth, dWidth1
     Set Rect = ActiveSheet.Shapes(1)
     Set progbar = ActiveSheet.Shapes(2)
     With progbar
          .Width = Rect.Width
          .Left = Rect.Left
          .Top = Rect.Top
          .Height = Rect.Height
     End With
     t1 = Timer
     t2 = Timer + 20
     Do
          dWidth = WorksheetFunction.Ceiling_Math((Timer - t1) / 20, 0.05)
          If dWidth <> dWidth1 Then
               progbar.Width = Rect.Width * dWidth
               DoEvents
               DoEvents
               dWidth1 = dWidth
          End If
     Loop While t <= Timer And Timer < t2
End Sub