XL 2019 Saisi clavier dans une feuille de calcul

C

Cemalatowilo

XLDnaute Nouveau
Bonjour,
Est-il possible de détecter l'appuie sur n'importe qu'elle touche du clavier lorsque l'on est sur une feuille de calcul?
Je pense à utiliser Keypress, mais je ne sais pas comment m'y prendre.
Merci
 
Trier par date Trier par votes
C

Cemalatowilo

XLDnaute Nouveau
Yeahou à dit:
ben nous non plus, sans fichier :rolleyes:

👍🤭
Cliquez pour agrandir...
Bonsoir,
Voici mon fichier.
J'ai désactiver la partie qui intercepte le message d'erreur.
J'ai créer 2 boutons pour démarrer et arréter le programme récursif en cas de problème
Depuis ce matin, j'ai longuement utiliser mon classeur. En réalité il ne fonctionne pas si bien que cela. Excel s'éteint subrepticement pour redémarrer tout seul!
Merci de ton temps
 

Pièces jointes

  • 21.03.06 Test segment.xlsm
    71.9 KB · Affichages: 16
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Bonjour Cematowilo

Pas terrible, une boucle de test permanente, cela finit forcément par saturer les piles d'exécution.
Je te propose de passer plutôt par ontime
Comme tu n'avais pas de module installé, j'ai laissé l'intégralité du code dans la feuille concernée, il faut passer par le codename pour utiliser une proc de feuille avec ontime (sans module installé), cela fonctionne très bien. J'en ai profité pour modifier la macro pour qu'elle teste et ne modifie la position des shapes que si besoin avec un test pour bloquer la récursivité du ontime si la proc est déja en cours d'exécution.
J'ai laissé un appel par Thisworkbook.open pour lancer l'exécution si la feuille "Dépense 2021" est déja la feuille active par défaut au lancement du classeur
Dis moi si cela te convient, cela me semble pas mal !

Bien cordialement

code de la feuille "Dépense 2021"
VB: 
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Set SegmentShape1 = Me.Shapes("Ss type")
    Set SegmentShape2 = Me.Shapes("Bénéficiaire")
    Set SegmentShape3 = Me.Shapes("Type")
    Set SegmentShape4 = Me.Shapes("Où")
    Set SegmentShape5 = Me.Shapes("Désignation")
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub

Code pour Thisworkbook, pas indispensable
Code: 
Private Sub Workbook_Open()
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Modif, j'ai enlevé les référencement à l'activation de la feuille, quand j'ai ajouté le référencement conditionnel pour Thisworkbook, je n'avais pas vu qu'il n'était plus nécessaire à l'activation de la feuille
Code: 
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
 

Pièces jointes

  • Copie de 21.03.06 Test segment.xlsm
    70.8 KB · Affichages: 6
Vote positif 0 Vote négatif
C

Cemalatowilo

XLDnaute Nouveau
Yeahou à dit:
Bonjour Cematowilo

Pas terrible, une boucle de test permanente, cela finit forcément par saturer les piles d'exécution.
Je te propose de passer plutôt par ontime
Comme tu n'avais pas de module installé, j'ai laissé l'intégralité du code dans la feuille concernée, il faut passer par le codename pour utiliser une proc de feuille avec ontime (sans module installé), cela fonctionne très bien. J'en ai profité pour modifier la macro pour qu'elle teste et ne modifie la position des shapes que si besoin avec un test pour bloquer la récursivité du ontime si la proc est déja en cours d'exécution.
J'ai laissé un appel par Thisworkbook.open pour lancer l'exécution si la feuille "Dépense 2021" est déja la feuille active par défaut au lancement du classeur
Dis moi si cela te convient, cela me semble pas mal !

Bien cordialement

code de la feuille "Dépense 2021"
VB: 
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Set SegmentShape1 = Me.Shapes("Ss type")
    Set SegmentShape2 = Me.Shapes("Bénéficiaire")
    Set SegmentShape3 = Me.Shapes("Type")
    Set SegmentShape4 = Me.Shapes("Où")
    Set SegmentShape5 = Me.Shapes("Désignation")
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub

Code pour Thisworkbook, pas indispensable
Code: 
Private Sub Workbook_Open()
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
Cliquez pour agrandir...
merci pour tout Yeahou, j'étudierai cela ce soir.
 
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Bonjour Cematowilo

j'ai re activé tes boutons pour stopper et redémarrer la proc, je ne l'avais pas fait dans la version précédente.

@+
VB: 
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_en_Cours As Boolean
Private Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    If Not Test_en_Cours Then
        Test_en_Cours = True
        If SegmentShape1 Is Nothing Then
            Set SegmentShape1 = Me.Shapes("Ss type")
            Set SegmentShape2 = Me.Shapes("Bénéficiaire")
            Set SegmentShape3 = Me.Shapes("Type")
            Set SegmentShape4 = Me.Shapes("Où")
            Set SegmentShape5 = Me.Shapes("Désignation")
        End If
        With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
            premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
        End With
        If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
            SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
            SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
            SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
            SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
        End If
        If ActiveSheet.Name = "Dépense 2021" Then Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
        Test_en_Cours = False
    End If
End Sub
Private Sub Worksheet_Activate()
    Test_en_Cours = False
    Application.OnTime Now() + TimeValue("00:00:01"), "'" & ThisWorkbook.Name & "'!" & ThisWorkbook.Worksheets("Dépense 2021").CodeName & ".FixeSegment"
End Sub
Private Sub Stop_FixeSegement()
    Test_en_Cours = True
End Sub
Private Sub Redemarre_FixeSegement()
    Test_en_Cours = False
    FixeSegment
End Sub
 

Pièces jointes

  • Copie de 21.03.06 Test segment.xlsm
    70.6 KB · Affichages: 2
Vote positif 0 Vote négatif
Bernard_XLD

Bernard_XLD

XLDnaute Barbatruc
Membre du Staff
Supporter XLD
Re
et si tu veux garder ta première version, j'ai modifié quelques trucs qui devrait l'améliorer, à tester
Référencement des shapes si besoin
Repositionnement des shapes si besoin
la procédure récursive ne lance FixeSegment que s'il n'est pas déja en cours d'exécution
Tu pourras modifier tes objets mais je pense que la pile d'exécution finira quand même par saturer
Cordialement
VB: 
Option Explicit
Public Depart As Single: Public Delta As Single
Public StopLanceur As Boolean
Dim SegmentShape1 As Shape
Dim SegmentShape2 As Shape
Dim SegmentShape3 As Shape
Dim SegmentShape4 As Shape
Dim SegmentShape5 As Shape
Dim premiereLigne As Integer
Dim Test_FixeSegment As Boolean

Sub FixeSegment()
'Cale les segments prédéfinis sur la deuxième ligne visible de l'écran
'Pour un gain de temps, aucune vérification d'existence de segments
'n'est faite
    Test_FixeSegment = True
    If SegmentShape1 Is Nothing Then
        Set SegmentShape1 = Me.Shapes("Ss type")
        Set SegmentShape2 = Me.Shapes("Bénéficiaire")
        Set SegmentShape3 = Me.Shapes("Type")
        Set SegmentShape4 = Me.Shapes("Où")
        Set SegmentShape5 = Me.Shapes("Désignation")
    End If
    With ActiveWindow.VisibleRange 'Détermine toutes les cellules visibles à l'écran
        premiereLigne = .Row 'Prend le numéro de la première ligne visible à l'écran
    End With
    If Not SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top Then
        SegmentShape1.Top = Cells(premiereLigne + 1, 1).Top 'Cale le segment sur la deuxième ligne visible à l'écran
        SegmentShape2.Top = Cells(premiereLigne + 1, 1).Top
        SegmentShape3.Top = Cells(premiereLigne + 1, 1).Top
        SegmentShape4.Top = Cells(premiereLigne + 27, 1).Top
        SegmentShape5.Top = Cells(premiereLigne + 1, 1).Top
    End If
    Test_FixeSegment = False
End Sub
Sub Lanceur()
    'Procédure récursive qui permet d'appeler FiweSegment tous les Delta seconde
    'On Error GoTo ErreurClavier
    'Application.EnableCancelKey = xlErrorHandler 'Permet de contrôler l'erreur qui m'indique que je ne peux pas utiliser
                                                 'quand je modifie une cellule
   
    Delta = 0.01
    StopLanceur = False 'Par défaut Lanceur est actif
    While True
        Depart = Timer
        While Timer <= Depart + Delta
            DoEvents 'Rend la main à l'utilisateur et au système
            If StopLanceur = True Then Exit Sub 'Arrète la procédure récursive
        Wend
        If Not Test_FixeSegment Then FixeSegment 'exécute FixeSegment
        Lanceur 'Relance la procédure récursive
    Wend
   
ErreurClavier:
    If Err = 18 Then
        StopperLanceur
    End If
End Sub
Sub StopperLanceur()
    StopLanceur = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
C

Cemalatowilo

XLDnaute Nouveau
J'ai étudié ta procédure avec application.ontime. Elle fonctionne bien, mais le mouvement des segments est moins lissé, c'est pourquoi j'avais essayé avec Timer qui permet de descendre l'incrément de temps en-dessous de la seconde.
Comme tu l'as suggéré, j'ai mis le code dans un module. Il est plus clair ainsi. je te joins le fichier modifié

je vais maintenant regardé le fichier avec Timer que tu as modifié.
Merci
 

Pièces jointes

  • 21.03.06 Test segment corrigé.xlsm
    67.4 KB · Affichages: 3
Vote positif 0 Vote négatif
C

Cemalatowilo

XLDnaute Nouveau
Re bonsoir,
J'ai repris ton code modifié avec Timer.
Effectivement il y a un toujours un dépassement de la capacité de la pile.
J'essaye de la contourner en gérant l'erreur de la manière suivante:
VB: 
Sub Lanceur()
    On Error GoTo ErreurPile
...
...
ErreurPile:
    If Err.Number = 28 Then
        Err.Clear
        Feuil7.Lanceur
    End If
End Sub
Mais cela ne fonctionne pas!
Une idée?
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
Microsoft 365 Clavier virtuel: SelectionChange, empêche la répétition
Réponses
3
Affichages
355
Simon 1234
S
N
  • Question
Microsoft 365 Alimenter une Combo Active X inséré dans une feuille de calcul
Réponses
3
Affichages
165
NONO14
N
M
  • Question
XL 2021 Colorer avec condition de temps
2
Réponses
27
Affichages
725
matlatarte
M
Wayat
  • Question
XL 2019 Date et mise en forme conditionnelle
Réponses
5
Affichages
570
fanfan38
fanfan38
E
  • Question
Microsoft 365 effacer formule en fonction de ce qui a été saisi dans une autre cellule
Réponses
6
Affichages
378
Phil69970
Phil69970
Z
  • Question
XL 2021 InputBox and focus à la fin de la ligne d'une valeur par défaut
Réponses
4
Affichages
272
zedude
Z
T
  • Question
XL 2016 % de budget total = calcul ou info TCD
Réponses
4
Affichages
259
tuti
T
B
  • Question
Autres Problème de macro
2
Réponses
17
Affichages
526
BDMNLLL47
B
chinel
  • Résolu(e)
XL 2016 problème de calcul avec heures
Réponses
7
Affichages
373
Gégé-45550
Gégé-45550
C
  • Question
XL 2021 Saisir dans liste userform
Réponses
2
Affichages
170
candido57
C

Membres actuellement en ligne

15 membres et 174 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 146
Messages
2 116 753
Membres
112 850
dernier inscrit
hfhgfhg