XL 2019 Gérer la descente d'une cellule colorer selon un timer

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Nicolas JACQUIN

Nicolas JACQUIN

XLDnaute Accro
Supporter XLD
Bonjour à toutes et tous,

Je cherche une façon de faire descendre une cellule ligne par ligne à un rytme différent (style tétris) selon valeur en "A1" (valeur pouvant aller de 1 à 15),
mais je n'arrive pas à gérer la vitesse, actuellement si je mets valeur de 1 à 5, pas de différence et si je mets 6 on vois plus rien.

VB: 
Sub DescenteCellule()
    Dim vitesse As Double
    Dim delai As Double
    Dim i As Integer
    Dim couleur As Long

    If IsNumeric(Range("A1").Value) Then
        vitesse = Range("A1").Value
        If vitesse <= 0 Then
            MsgBox "La valeur de A1 doit être supérieure à 0.", vbExclamation
            Exit Sub
        End If
    Else
        MsgBox "Veuillez entrer un nombre valide dans la cellule A1.", vbExclamation
        Exit Sub
    End If

    delai = 1 / (1 + (vitesse - 1) * 0.2)
    couleur = Range("D5").Interior.Color
    Range("D5:D25").Interior.ColorIndex = xlNone

    For i = 5 To 25
        Range("D5:D25").Interior.ColorIndex = xlNone
        Range("D" & i).Interior.Color = couleur
        DoEvents
        Application.Wait Now + TimeSerial(0, 0, delai)
    Next i

    Range("D25").Interior.ColorIndex = xlNone
    Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
End Sub

Merci à tous.
Nicolas
 

Pièces jointes

Trier par date Trier par votes
Bonjour Nicolas,
une proposition qui utilise simplement une boucle qui ne fait rien
VB: 
Sub DescenteCellule()
    Dim vitesse As Double
    Dim delai As Double
    Dim i As Integer, j As Double
    Dim couleur As Long

    If IsNumeric(Range("A1").Value) Then
        vitesse = Range("A1").Value
        If vitesse <= 0 Then
            MsgBox "La valeur de A1 doit être supérieure à 0.", vbExclamation
            Exit Sub
        End If
    Else
        MsgBox "Veuillez entrer un nombre valide dans la cellule A1.", vbExclamation
        Exit Sub
    End If
   
    'delai = 1 / (1 + (vitesse - 1) * 0.2)
    couleur = Range("D5").Interior.Color
    Range("D5:D25").Interior.ColorIndex = xlNone

    For i = 5 To 25
        Range("D5:D25").Interior.ColorIndex = xlNone
        Range("D" & i).Interior.Color = couleur
        DoEvents
        'Application.Wait Now + TimeSerial(0, 0, delai)
        For j = 1 To Int(10000000 / vitesse)
        Next j
    Next i

    Range("D25").Interior.ColorIndex = xlNone
    Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
End Sub
 
Vote positif 0 Vote négatif
Bonjour.
Je pense que Application.Wait ne permet que des durées d'attentes à la seconde près.
J'utiliserais ça :
VB: 
Option Explicit
                        #If VBA7 Then
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
                        #Else
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
                           #End If
Sub Attendre(ByVal DuréeSec As Double)
   Static CtrPré As Currency
   Dim CtrAct As Currency, Fréq As Currency
   If CtrPré = 0 Then QueryPerformanceCounter CtrPré
   QueryPerformanceFrequency Fréq
   Do: QueryPerformanceCounter CtrAct
      If (CtrAct - CtrPré) / Fréq >= DuréeSec Then Exit Do
      DoEvents: Loop
   CtrPré = CtrPré + DuréeSec * Fréq
   End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Hello,
crocrocro et Dranreb vos boucles ne sont pas bonnes pour la planète, cela mange du temps CPU.
Utiliser plutôt un sleep (pas Kangourou) dans une temporisation.
par exemple pour une tempo en centaine de ms ( 1 = 100ms, 10 = 1 seconde):
VB: 
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub Tempo(t)
  Dim x As Integer
  For x = 0 To t - 1
    Sleep 100: DoEvents
  Next x
End Sub

Ami calmant, J.P
 
Vote positif 0 Vote négatif
Bonjour à tous et merci pour vos réponse,

@crocrocro , niveau 2 dejà je mets au défi de faire un tétris, mais je garde dans mes tiroirs, merci
@Dranreb , ça rame, pas moyen
@jurassic pork , l'idée à l'ai bien, faut que je regarde un peu plus

L'idée était pour ci-dessous, c'est un démarrage mais je peine sur cette partie descente

Animation2.gif


Merci
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour le forum,

Pour des vitesses de 1 à 1000 en A1 le Timer à l'air de bien fonctionner :
VB: 
Sub DescenteCellule()
    Dim vitesse As Double, delai As Double, couleur As Long, i As Integer, t As Double
    
    vitesse = Int(Val(Range("A1")))
    Range("A1") = vitesse
    If vitesse <= 0 Then MsgBox "La valeur de A1 doit être supérieure à 0.", vbExclamation:  Exit Sub
    delai = 1 / (1 + (vitesse - 1) * 0.2)
    couleur = Range("D5").Interior.Color

    For i = 5 To 25
        t = Timer + delai
        While Timer < t And t < 86400: DoEvents: Wend
        Range("D" & i - 1).Interior.ColorIndex = xlNone
        Range("D" & i).Interior.Color = couleur
    Next i

    Range("D25").Interior.ColorIndex = xlNone
    Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Bonjour le forum,

Pour des vitesses de 1 à 1000 en A1 le Timer à l'air de bien fonctionner :
VB: 
Sub DescenteCellule()
    Dim vitesse As Double, delai As Double, couleur As Long, i As Integer, t As Double
   
    vitesse = Int(Val(Range("A1")))
    Range("A1") = vitesse
    If vitesse <= 0 Then MsgBox "La valeur de A1 doit être supérieure à 0.", vbExclamation:  Exit Sub
    delai = 1 / (1 + (vitesse - 1) * 0.2)
    couleur = Range("D5").Interior.Color

    For i = 5 To 25
        t = Timer + delai
        While Timer < t And t < 86400: DoEvents: Wend
        Range("D" & i - 1).Interior.ColorIndex = xlNone
        Range("D" & i).Interior.Color = couleur
    Next i

    Range("D25").Interior.ColorIndex = xlNone
    Range("D5").Interior.Color = RGB(0, 255, 0) ' Vert
End Sub
A+
Cliquez pour agrandir...
Bonjour, je vais regarder, merci beaucoup
 
Vote positif 0 Vote négatif
Bonjour à tous 😉,

Pour le fun, une autre possibilité basée sur une boucle de DoEvents mais avec pseudo calibrage préalable (au premier déplacement).

nota 1 : comme on n'utilise pas les API, comme on utilise une boucle DoEvents, comme on utilise Timer (pour les valeurs), toutes les durées ne peuvent qu'être approximatives. Le facteur de "correction" est déterminé de façon empirique au doigt mouillé et doit dépendre de la machine utilisée. L'important à mon avis n'est pas le temps global mais l'effet visuel constaté en fonction de la valeur de A1, non ?

nota 2 : ça devrait être utilisable sur Apple.

nota 3 : juste à la première descente, le temps d'exécution est un peu plus long car on procède au pseudo- calibrage

Le code :
VB: 
Option Explicit
Dim Coeff#

Sub DescenteCellule()
Const Empirique = 1.4                                 ' correction empirique au doigt mouillé
Dim couleur&, i&, k&, kfin#, debut, x
   If Coeff = 0 Then Coeff = calibrage                ' calibrage si coeff est égal à zéro
   [k2] = ""
   couleur = couleurD5                                ' une couleur au hasard
   [d5:d25].Interior.ColorIndex = xlColorIndexNone    ' plage sans couleur de fond
   kfin = [a1] / 1000 * Coeff / Empirique             ' nombre de "DoEvents" entre 2 déplacements
   debut = Timer
   [D5].Interior.Color = couleur                      ' couleur de fond de la cellule de départ
   For i = 1 To [d5:d25].Rows.Count - 1               ' boucle sur la plage
       For k = 1 To kfin: DoEvents: Next              ' tempo
       [D5].Offset(i - 1).Interior.ColorIndex = xlColorIndexNone  ' effacement du fond de la cellule colorée
       [D5].Offset(i).Interior.Color = couleur                    ' couleur de fond de la cellule à colorer
   Next i
   [k2] = 1000# * (Timer - debut)         ' calcul de la durée total (approximatif)
   [a1].Select                            ' sélection de la prochaine vitesse
End Sub

Function calibrage() As Double
Dim tdeb#, tfin#, n#
   tfin = Time + (1# / 86400)                         ' heure de fin (correspond à une seconde)
   Do: n = n + 1: DoEvents: Loop Until Time > tfin    ' comptage des "DoEvents" en une seconde
   calibrage = n                                      ' retour du calibrage (/ 2 = ajustement pifométrique)
End Function

Function couleurD5()    ' déterminer une couleur au hasard
   Randomize
   couleurD5 = RGB(1 + Rnd * 255, 1 + Rnd * 255, 1 + Rnd * 255)
End Function
 

Pièces jointes

Vote positif 0 Vote négatif
mapomme à dit:
Bonjour à tous 😉,

Pour le fun, une autre possibilité basée sur une boucle de DoEvents mais avec pseudo calibrage préalable (au premier déplacement).

nota 1 : comme on n'utilise pas les API, comme on utilise une boucle DoEvents, comme on utilise Timer (pour les valeurs), toutes les durées ne peuvent qu'être approximatives. Le facteur de "correction" est déterminé de façon empirique au doigt mouillé et doit dépendre de la machine utilisée. L'important à mon avis n'est pas le temps global mais l'effet visuel constaté en fonction de la valeur de A1, non ?

nota 2 : ça devrait être utilisable sur Apple.

nota 3 : juste à la première descente, le temps d'exécution est un peu plus long car on procède au pseudo- calibrage

Le code :
VB: 
Option Explicit
Dim Coeff#

Sub DescenteCellule()
Const Empirique = 1.4                                 ' correction empirique au doigt mouillé
Dim couleur&, i&, k&, kfin#, debut, x
   If Coeff = 0 Then Coeff = calibrage                ' calibrage si coeff est égal à zéro
   [k2] = ""
   couleur = couleurD5                                ' une couleur au hasard
   [d5:d25].Interior.ColorIndex = xlColorIndexNone    ' plage sans couleur de fond
   kfin = [a1] / 1000 * Coeff / Empirique             ' nombre de "DoEvents" entre 2 déplacements
   debut = Timer
   [D5].Interior.Color = couleur                      ' couleur de fond de la cellule de départ
   For i = 1 To [d5:d25].Rows.Count - 1               ' boucle sur la plage
       For k = 1 To kfin: DoEvents: Next              ' tempo
       [D5].Offset(i - 1).Interior.ColorIndex = xlColorIndexNone  ' effacement du fond de la cellule colorée
       [D5].Offset(i).Interior.Color = couleur                    ' couleur de fond de la cellule à colorer
   Next i
   [k2] = 1000# * (Timer - debut)         ' calcul de la durée total (approximatif)
   [a1].Select                            ' sélection de la prochaine vitesse
End Sub

Function calibrage() As Double
Dim tdeb#, tfin#, n#
   tfin = Time + (1# / 86400)                         ' heure de fin (correspond à une seconde)
   Do: n = n + 1: DoEvents: Loop Until Time > tfin    ' comptage des "DoEvents" en une seconde
   calibrage = n                                      ' retour du calibrage (/ 2 = ajustement pifométrique)
End Function

Function couleurD5()    ' déterminer une couleur au hasard
   Randomize
   couleurD5 = RGB(1 + Rnd * 255, 1 + Rnd * 255, 1 + Rnd * 255)
End Function
Cliquez pour agrandir...

Bonjour, l'idée est très bonne mais j'ai du mal à adapter, merci
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Résolu(e)
XL 2019 Remplacer un mot et ajouter une couleur
Réponses
7
Affichages
182
Attila451
A
A
  • Question Question
XL 2019 Copie d'une valeur dans la cellule à côté d'une valeur trouvé
Réponses
1
Affichages
78
sylvanu
sylvanu
G
  • Question Question
XL 2016 # MFC applicable selon valeur autre cellule Vba
Réponses
9
Affichages
539
TooFatBoy
TooFatBoy
T
  • Résolu(e)
Microsoft 365 VBA Exporter une sélection de plages nommées au format PDF
Réponses
12
Affichages
198
tnion
T
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
284
patricktoulon
patricktoulon
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
385
CortoXls
C
P
  • Résolu(e)
Microsoft 365 Macro qui change l'épaisseur du contour d'une forme
Réponses
11
Affichages
573
pat66
P
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
436
patricktoulon
patricktoulon
pascal21
  • Question Question
Microsoft 365 selectionner cellule via un combobox
Réponses
3
Affichages
90
job75
job75
A
  • Question Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
371
sylvanu
sylvanu
C
  • Question Question
XL 2016 VBA - Mettre en Indice une partie du contenu d'une cellule : problème avec la propriété Font.Subscript
Réponses
2
Affichages
146
crocrocro
C
S
  • Question Question
Microsoft 365 Colorer automatiquement des cellules en les sélectionnant
Réponses
5
Affichages
537
Jacky67
Jacky67
H
  • Résolu(e)
XL 2016 Copier cellule dans un autre onglets
2
Réponses
16
Affichages
490
Phil69970
Phil69970
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
496
Gestionnaire_rh
G
S
  • Question Question
XL 2013 enregistrer une feuille excel converti en pdf dans un répertoire selon la valeur d'une cellule
Réponses
5
Affichages
270
Phil69970
Phil69970
piga25
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
155
piga25
piga25
piga25
  • Résolu(e)
XL 2016 Mettre la même couleur de la dernière cellule colorée
Réponses
5
Affichages
393
TooFatBoy
TooFatBoy
Jojo973
  • Question Question
Microsoft 365 Trouver et attribuer une plage de cellule en fonction de la cellule active
Réponses
6
Affichages
465
Jojo973
Jojo973
A
  • Question Question
XL 2016 Macro et rajout d'un chiffre au nom d'un Shape
Réponses
9
Affichages
661
alain.raphael
A
D
  • Question Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
703
dadu35
D
Retour