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: 25
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

F
  • Résolu(e)
Microsoft 365 Copier juste couleur cellule.
Réponses
7
Affichages
306
Francky79
F
halecs93
  • Résolu(e)
XL 2016 Appliquer sur une sélection la couleur d'une autre cellule
Réponses
4
Affichages
131
halecs93
halecs93
S
  • Question
Microsoft 365 Changement automatique de la couleur de la cellule clonée
Réponses
7
Affichages
318
danielco
D
M
  • Question
XL 2013 changement de couleur de police qd cellule modifiée
Réponses
10
Affichages
285
michel.dupont
M
F
  • Résolu(e)
Microsoft 365 Mise en forme conditionnelle selon la référence d'une cellule
Réponses
3
Affichages
116
filiph79
F
P
  • Résolu(e)
XL 2019 Couleur recopiée automatiquement sur la couleur d'une autre cellule.
Réponses
5
Affichages
580
sylvanu
sylvanu
J
  • Question
Combobox - Scroller avec la souris
Réponses
6
Affichages
147
patricktoulon
patricktoulon
N
  • Question
Microsoft 365 couleur de cellule en fonction de date echeance
Réponses
2
Affichages
314
natadom
N
M
  • Question
Autres copier la couleur d'une cellule
Réponses
4
Affichages
471
michel1941
M
R
  • Question
XL 2019 Colorer des shapes en récupérant la couleur d'une cellule
2
Réponses
16
Affichages
826
ruliann
R

Membres actuellement en ligne

3 membres et 57 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
312 177
Messages
2 085 972
Membres
103 073
dernier inscrit
MSCHOE16