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
Nicolas JACQUIN à dit:
Jo, du hesch recht (du hesch iwwerall dini Nàs), ich ha zwischendurch mini Dateià übersprunge, mìn Fèhler, es dut mer leid. Schmutz!
Cliquez pour agrandir...
Je mets la traduction donnée par l'appli installée sur mon tél 😅 😂 🤣 :

Screenshot_20250519_174137_Translate.jpg


Je précise quand même que la traduction du dernier mot semble ne pas tout à fait être la bonne...
😚 Nico
 
Vote positif 0 Vote négatif
Nicolas JACQUIN à dit:
Non mais sérieusement, si quelqu'un peut m'aider ça m'arrengerai 🙂 🙂
Cliquez pour agrandir...
Hello,
une piste :
un module Tempo :
VB: 
Option Explicit

#If Mac Then
    #If VBA7 Then
        Public Declare PtrSafe Sub USleep Lib "/usr/lib/libc.dylib" Alias "usleep" (ByVal dwMicroseconds As Long)
    #Else
        Public Declare Sub USleep Lib "/usr/lib/libc.dylib" Alias "usleep" (ByVal dwMicroseconds As Long)
    #End If
#Else 'Windows
    #If VBA7 Then
        Private Declare PtrSafe Sub MSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
    #Else
        Private Declare  Sub MSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
    #End If
#End If

Public Sub Sleep(ByVal dwMilliseconds As Long)
#If Mac Then
    USleep dwMilliseconds * 1000&
#Else
    MSleep dwMilliseconds
#End If
End Sub

Sub Tempo(x) ' tempo en millisecondes (min 50 et multiple de 50)
Dim t As Integer
For t = 0 To (x / 50) - 1: Sleep 50: DoEvents: Next t
End Sub
et adaptation dans le code :
Code: 
Sub NouvellePiece()
    Dim r As Integer
    r = FileAttente(1)
    
    ' Décaler la file
    Dim i As Integer
    For i = 1 To TAILLE_ATTENTE - 1
        FileAttente(i) = FileAttente(i + 1)
    Next i
    FileAttente(TAILLE_ATTENTE) = Int(Rnd * 7)
    
    ' Charger la nouvelle pièce
    FormeActuelle = ListeFormes(r).Cells
    CouleurActuelle = ListeFormes(r).couleur

    PositionX = LIGNE_DEBUT
    PositionY = Int((COLONNE_FIN - COLONNE_DEBUT - 2) / 2) + COLONNE_DEBUT

    If Collision(0, 0) Then
        MsgBox "Game Over", vbExclamation
        TimerActive = False
        Exit Sub
    End If

    AfficherFileAttente
    AfficherPiece FormeActuelle, True, CouleurActuelle

    If Not TimerActive Then
        TimerActive = True
        Tempo IntervalleDescente * 1000
        Tick
      '  Application.OnTime Now + (IntervalleDescente / 86400), "Tick"
    End If
End Sub

Sub Tick()
 '   If TimerActive Then
     While TimerActive
        Descendre
       ' Application.OnTime Now + IntervalleDescente / 86400, "Tick"
        Tempo IntervalleDescente * 1000
     Wend
 '   End If
End Sub

Ami calmant, J.P
 
Vote positif 0 Vote négatif
jurassic pork à dit:
Hello,
une piste :
un module Tempo :
VB: 
Option Explicit

#If Mac Then
    #If VBA7 Then
        Public Declare PtrSafe Sub USleep Lib "/usr/lib/libc.dylib" Alias "usleep" (ByVal dwMicroseconds As Long)
    #Else
        Public Declare Sub USleep Lib "/usr/lib/libc.dylib" Alias "usleep" (ByVal dwMicroseconds As Long)
    #End If
#Else 'Windows
    #If VBA7 Then
        Private Declare PtrSafe Sub MSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
    #Else
        Private Declare  Sub MSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
    #End If
#End If

Public Sub Sleep(ByVal dwMilliseconds As Long)
#If Mac Then
    USleep dwMilliseconds * 1000&
#Else
    MSleep dwMilliseconds
#End If
End Sub

Sub Tempo(x) ' tempo en millisecondes (min 50 et multiple de 50)
Dim t As Integer
For t = 0 To (x / 50) - 1: Sleep 50: DoEvents: Next t
End Sub
et adaptation dans le code :
Code: 
Sub NouvellePiece()
    Dim r As Integer
    r = FileAttente(1)
   
    ' Décaler la file
    Dim i As Integer
    For i = 1 To TAILLE_ATTENTE - 1
        FileAttente(i) = FileAttente(i + 1)
    Next i
    FileAttente(TAILLE_ATTENTE) = Int(Rnd * 7)
   
    ' Charger la nouvelle pièce
    FormeActuelle = ListeFormes(r).Cells
    CouleurActuelle = ListeFormes(r).couleur

    PositionX = LIGNE_DEBUT
    PositionY = Int((COLONNE_FIN - COLONNE_DEBUT - 2) / 2) + COLONNE_DEBUT

    If Collision(0, 0) Then
        MsgBox "Game Over", vbExclamation
        TimerActive = False
        Exit Sub
    End If

    AfficherFileAttente
    AfficherPiece FormeActuelle, True, CouleurActuelle

    If Not TimerActive Then
        TimerActive = True
        Tempo IntervalleDescente * 1000
        Tick
      '  Application.OnTime Now + (IntervalleDescente / 86400), "Tick"
    End If
End Sub

Sub Tick()
 '   If TimerActive Then
     While TimerActive
        Descendre
       ' Application.OnTime Now + IntervalleDescente / 86400, "Tick"
        Tempo IntervalleDescente * 1000
     Wend
 '   End If
End Sub

Ami calmant, J.P
Cliquez pour agrandir...

Bonjour @jurassic pork ,

Merci du retour, je vais regarder quand j'aurai un peu de temps,
je viens juste de voir ton message entre les conneries que j'ai sortie.

Merci à toi.

Nicolas
 
Vote positif 0 Vote négatif
Bonjour,
Personnellement, si je devais faire un Tetris j'utiliserai le tic du timer {module de classe MyTimer que je t'avais fournis pour les marées} pour faire avancer le shmilbique.

En d'autres termes comme pour le Tetris je fais dessandre la mise en forme d'une ligne à chaque tic qui dépend de la valeur de l'interval choisi

Il ne faut pas oublier qu'excel est relativement lent et que descendre à 1 millisecondes reste une utopie.

Par exemple si je positions le timer a 200 millisecondes l'événement click sur un bouton n'est pas détecté, il m'as fallu passer à 300 millisecondes. C'est pas pour autant que l'affichage fut si réactif.
 
Dernière édition:
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