Microsoft 365 changement couleur cellule au survol de la souris

J

josianejbg

XLDnaute Nouveau
Bonjour à tous,
Je suis nouvelle et d'ores et déjà j'aimerai avoir votre aide.
Je fais beaucoup de tableaux avec excel et je souhaiterai, lors du survol avec la souris ou avec les touches direction clavier, que la cellule change de couleur mais dès que je passe à une autre cellule, la première reprend sa couleur initiale.
J'ai tenté des solutions mais hélas ça ne fait pas comme je veux ( entre autre la couleur ne revient pas à sa couleur initiale).
Je ne suis pas une pro, alors SVPM, une procèdure à faire pas à pas .
d'avance merci
bonne journée
 
Solution
patricktoulon
VB: 
Option Explicit
Dim oldcell As Range
Dim chang As Boolean

Private Sub Workbook_BeforeClose(Cancel As Boolean)
        If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
        Application.OnKey "{UP}"
        Application.OnKey "{DOWN}"
        Application.OnKey "{LEFT}"
        Application.OnKey "{RIGHT}"
End Sub

Private Sub Workbook_Open(): detourneTouche: End Sub
Public Sub updownleftright(arg As String)
    chang = True
    Select Case arg
    Case "{UP}": If ActiveCell.Row > 1 Then ActiveCell.Offset(-1).Select
    Case "{DOWN}": If ActiveCell.Row < Rows.Count Then ActiveCell.Offset(1).Select
    Case "{LEFT}": If ActiveCell.Column > 1 Then ActiveCell.Offset(, -1).Select
    Case "{RIGHT}": If ActiveCell.Column <...
Trier par date Trier par votes
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
un exemple
ouvre un nouveau classeur et colle tout ce code dans le module "ThisWorkBook"
VB: 
Option Explicit
Dim oldcell As Range
Dim chang As Boolean
Private Sub Workbook_Open(): detourneTouche: End Sub
Public Sub updownleftright(arg As String)
    chang = True
    Select Case arg
    Case "{UP}": If ActiveCell.Row > 1 Then ActiveCell.Offset(-1).Select
    Case "{DOWN}": If ActiveCell.Row < Rows.Count Then ActiveCell.Offset(1).Select
    Case "{LEFT}": If ActiveCell.Column > 1 Then ActiveCell.Offset(, -1).Select
    Case "{RIGHT}": If ActiveCell.Column < Columns.Count Then ActiveCell.Offset(, 1).Select
    End Select
End Sub
Sub detourneTouche()
    If ActiveSheet.Index = 1 Then
        Application.OnKey "{UP}", "'ThisWorkBook.updownleftright ""{UP}""'"
        Application.OnKey "{DOWN}", "'ThisWorkBook.updownleftright ""{DOWN}""'"
        Application.OnKey "{LEFT}", "'ThisWorkBook.updownleftright ""{LEFT}""'"
        Application.OnKey "{RIGHT}", "'ThisWorkBook.updownleftright ""{RIGHT}""'"
    Else
        If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
        Application.OnKey "{UP}"
        Application.OnKey "{DOWN}"
        Application.OnKey "{LEFT}"
        Application.OnKey "{RIGHT}"
    End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object): detourneTouche: End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
    If Sh.Index = 1 Then
        If chang = True Then
            Target.Interior.Color = vbRed
            Set oldcell = Target
            chang = False
        End If
    End If
End Sub
et promène toi avec les flèches
j'ai bridé l'effet sur la feuille 1
;)
 
Vote positif 0 Vote négatif
herve62

herve62

XLDnaute Barbatruc
Supporter XLD
Bonjour
Il me semble qu'il y ait pas d'exemple sur le web !!!! ....en cherchant un peu ?
sinon il y a cette solution qui fonctionne mais à adapter à ton fichier puisque ....... pas joint ici !
Il est pas évident à comprendre , je te laisse l'astuce principale d ela feuille1 , un textbox superpose la cellule remet la bien en place ( se mettre en mode création), enregistre et re passe la souris normalement c'est vert puis revient à l'origine si tu cliques tu vas à la feuille avec le nom
C'est pas évident à comprendre , le pas à pas en debug ne marche pas ( cause événement)
A toi de jouer avec ......et de la patience
 

Pièces jointes

  • test-survol.xlsm
    60.6 KB · Affichages: 26
Vote positif 0 Vote négatif
J

josianejbg

XLDnaute Nouveau
patricktoulon à dit:
re
un exemple
ouvre un nouveau classeur et colle tout ce code dans le module "ThisWorkBook"
VB: 
Option Explicit
Dim oldcell As Range
Dim chang As Boolean
Private Sub Workbook_Open(): detourneTouche: End Sub
Public Sub updownleftright(arg As String)
    chang = True
    Select Case arg
    Case "{UP}": If ActiveCell.Row > 1 Then ActiveCell.Offset(-1).Select
    Case "{DOWN}": If ActiveCell.Row < Rows.Count Then ActiveCell.Offset(1).Select
    Case "{LEFT}": If ActiveCell.Column > 1 Then ActiveCell.Offset(, -1).Select
    Case "{RIGHT}": If ActiveCell.Column < Columns.Count Then ActiveCell.Offset(, 1).Select
    End Select
End Sub
Sub detourneTouche()
    If ActiveSheet.Index = 1 Then
        Application.OnKey "{UP}", "'ThisWorkBook.updownleftright ""{UP}""'"
        Application.OnKey "{DOWN}", "'ThisWorkBook.updownleftright ""{DOWN}""'"
        Application.OnKey "{LEFT}", "'ThisWorkBook.updownleftright ""{LEFT}""'"
        Application.OnKey "{RIGHT}", "'ThisWorkBook.updownleftright ""{RIGHT}""'"
    Else
        If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
        Application.OnKey "{UP}"
        Application.OnKey "{DOWN}"
        Application.OnKey "{LEFT}"
        Application.OnKey "{RIGHT}"
    End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object): detourneTouche: End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
    If Sh.Index = 1 Then
        If chang = True Then
            Target.Interior.Color = vbRed
            Set oldcell = Target
            chang = False
        End If
    End If
End Sub
et promène toi avec les flèches
j'ai bridé l'effet sur la feuille 1
;)
Cliquez pour agrandir...
PARFAIT CA MARCHE MERCI.
Par contre quand je ferme mon fichier et le réouvre, il faut refaire toute la procédure, est-ce normal ?
merci
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
VB: 
Option Explicit
Dim oldcell As Range
Dim chang As Boolean

Private Sub Workbook_BeforeClose(Cancel As Boolean)
        If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
        Application.OnKey "{UP}"
        Application.OnKey "{DOWN}"
        Application.OnKey "{LEFT}"
        Application.OnKey "{RIGHT}"
End Sub

Private Sub Workbook_Open(): detourneTouche: End Sub
Public Sub updownleftright(arg As String)
    chang = True
    Select Case arg
    Case "{UP}": If ActiveCell.Row > 1 Then ActiveCell.Offset(-1).Select
    Case "{DOWN}": If ActiveCell.Row < Rows.Count Then ActiveCell.Offset(1).Select
    Case "{LEFT}": If ActiveCell.Column > 1 Then ActiveCell.Offset(, -1).Select
    Case "{RIGHT}": If ActiveCell.Column < Columns.Count Then ActiveCell.Offset(, 1).Select
    End Select
End Sub
Sub detourneTouche()
        Application.OnKey "{UP}", "'ThisWorkBook.updownleftright ""{UP}""'"
        Application.OnKey "{DOWN}", "'ThisWorkBook.updownleftright ""{DOWN}""'"
        Application.OnKey "{LEFT}", "'ThisWorkBook.updownleftright ""{LEFT}""'"
        Application.OnKey "{RIGHT}", "'ThisWorkBook.updownleftright ""{RIGHT}""'"
 End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object): If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
 End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
         If chang = True Then
            Target.Interior.Color = vbRed
            Set oldcell = Target
            chang = False
        End If
   End Sub
 
Vote positif 0 Vote négatif
Solution
J

josianejbg

XLDnaute Nouveau
patricktoulon à dit:
VB: 
Option Explicit
Dim oldcell As Range
Dim chang As Boolean

Private Sub Workbook_BeforeClose(Cancel As Boolean)
        If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
        Application.OnKey "{UP}"
        Application.OnKey "{DOWN}"
        Application.OnKey "{LEFT}"
        Application.OnKey "{RIGHT}"
End Sub

Private Sub Workbook_Open(): detourneTouche: End Sub
Public Sub updownleftright(arg As String)
    chang = True
    Select Case arg
    Case "{UP}": If ActiveCell.Row > 1 Then ActiveCell.Offset(-1).Select
    Case "{DOWN}": If ActiveCell.Row < Rows.Count Then ActiveCell.Offset(1).Select
    Case "{LEFT}": If ActiveCell.Column > 1 Then ActiveCell.Offset(, -1).Select
    Case "{RIGHT}": If ActiveCell.Column < Columns.Count Then ActiveCell.Offset(, 1).Select
    End Select
End Sub
Sub detourneTouche()
        Application.OnKey "{UP}", "'ThisWorkBook.updownleftright ""{UP}""'"
        Application.OnKey "{DOWN}", "'ThisWorkBook.updownleftright ""{DOWN}""'"
        Application.OnKey "{LEFT}", "'ThisWorkBook.updownleftright ""{LEFT}""'"
        Application.OnKey "{RIGHT}", "'ThisWorkBook.updownleftright ""{RIGHT}""'"
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object): If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Not oldcell Is Nothing Then oldcell.Interior.Color = xlNone
         If chang = True Then
            Target.Interior.Color = vbRed
            Set oldcell = Target
            chang = False
        End If
   End Sub
Cliquez pour agrandir...
SUPER ENCORE MILLE MERCI
JE NE VOUS EMBETE PLUS - TOUT MARCHE A MERVEILLE
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2016 Changement de couleur cellule
Réponses
1
Affichages
192
Gégé-45550
Gégé-45550
P
  • Résolu(e)
XL pour MAC Problème de changement de couleur de la valeur d'une cellule
Réponses
2
Affichages
239
pvander
P
D
  • Question
Microsoft 365 mise en forme conditionnelle : choisir la couleur d'une autre cellule
Réponses
11
Affichages
410
deuxnid
D
Yann71
  • Question
Microsoft 365 Compter le nombre de cellule mise en couleur avec MFC
2
Réponses
19
Affichages
632
job75
job75
T
  • Question
XL 2021 Additionner la couleur du fond et la police de plusieurs cellule en vba
Réponses
7
Affichages
309
Tophe2
T
G
  • Question
XL 2016 SI (cellule de couleur) alors
Réponses
4
Affichages
590
Nicolas JACQUIN
Nicolas JACQUIN
treza88
  • Question
Microsoft 365 Copie de couleur d'une cellule à une autre
Réponses
11
Affichages
552
Dranreb
Dranreb
E
  • Question
Microsoft 365 Couleurs de fichiers qui changent
Réponses
1
Affichages
249
mapomme
mapomme
halecs93
  • Résolu(e)
XL 2016 Infobulles au passage de la souris
4 5 6
Réponses
80
Affichages
3 K
jcf6464
jcf6464
A
  • Résolu(e)
Microsoft 365 Compter cellule de couleur.
2
Réponses
27
Affichages
2 K
Anto35200
A

Membres actuellement en ligne

3 membres et 43 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
314 728
Messages
2 112 265
Membres
111 481
dernier inscrit
zrk