> Tous les forums > Forum Bureautique
 Mettre une ligne en couleurSujet résolu
Ajouter un message à la discussion
Page : [1] 
Page 1 sur 1
gpl85
  Posté le 26/09/2019 @ 15:59 
Aller en bas de la page 
Nouvel astucien

Bonjour aux astuciens,



J'ai trouvé dans le forum une astuce pour mettre la ligne active en couleur, sans perdre ses couleurs d'origine. Voici l'astuce :

Private Sub Worksheet_Deactivate()
ResetRow
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
iR = Target.Row
On Error Resume Next
If iLastR > 0 Then
For i = 1 To 256
Cells(iLastR, i).Interior.ColorIndex = Tablo(i)
Next
End If
For i = 1 To 256
Tablo(i) = Cells(Target.Row, i).Interior.ColorIndex
Next
Rows(iR).Interior.ColorIndex = 38
iLastR = iR
End Sub

Lorsque je l'utilise, il y a un blocage sur le mot "Tablo".

Merci de m'indiquer la correction à faire.

Cordialement,

Gpl85

[Configuration automatique à compléter]
Windows 10
Chrome 77.0.3865.90

Publicité
Debrief
 Posté le 27/09/2019 à 13:01 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

Bonjour,

Il y a plusieurs petits problèmes dans ce code.

1 - Il n'y a pas l'option Option Explicit en tête du code donc pas d'obligation de déclarer les variables ce qui n'est pas dans la nature d'un code sous contrôle.

2 - Tablo() est un tableau et lui n'échappe pas à une déclaration indiquant au moins que c'est un tableau(), c'est pour ça que ça plante.

3 - Tablo() et iLastR doivent conserver leurs valeurs d'un appel à un autre, et pour ça 2 solutions:
- déclarer ces variables statiques à l'intérieur de la procédure, mais leur visibilité restera pour la procédure uniquement
- déclarer ces variables au niveau du module pour qu'elles soient visibles de toutes les procédures du module
C'est la 2ème solution qu'il faut adopter car 2 procédures (Worksheet_SelectionChange et Worksheet_Deactivate) y font référence

4 - Ce système fonctionne sur la base d'une mémorisation du ColorIndex des 256 cellules en colonne de la ligne sélectionnée avant colorisation en rose (ColorIndex = 38)
Y en a pas bon du tout car:
- Le nombre de colonnes est 256 (colonne IV) pour Excel 97-2003 mais 16384 (colonne XFD) pour Excel au-delà.
- ColorIndex n'est pas représentatif de la couleur de fond, c'est Color qu'il faudrait stocker.

Cette méthode qui consiste à stocker la couleur des cellules à la sélection avant coloriage de la ligne puis la restituer sur une autre sélection n'est pas très bonne:
- à chaque sélection il faut faire une boucle de 16384 affectations pour stoker et 16384 affectations pour déstocker. Et ça prend de la CPU et rend la manip assez lente.
- S'il y a de MFC sur les cellules qui colorient ces cellules, les MFC seront toujours prioritaire et le coloriage sera sans effet.

Voici quand même ce code corrigé:

Option Explicit

Dim Tablo() As Long
Dim iLastR As Long
Dim NbColonnes As Integer

Private Sub Worksheet_Deactivate()
ResetRow
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iR As Long
Dim i As Integer
Dim VersionExcel As Integer

If NbColonnes = 0 Then
VersionExcel = Replace(Application.Version, ".", Application.DecimalSeparator)
If VersionExcel < 12 Then NbColonnes = 256 Else NbColonnes = 16384
ReDim Tablo(1 To NbColonnes)
End If

iR = Target.Row

Call ResetRow

For i = 1 To NbColonnes
Tablo(i) = Cells(Target.Row, i).Interior.Color
Next

Rows(iR).Interior.ColorIndex = 38
iLastR = iR
End Sub

Private Sub ResetRow()
Dim i As Integer

If iLastR > 0 Then
For i = 1 To NbColonnes
Cells(iLastR, i).Interior.Color = Tablo(i)
Next
End If
End Sub

Cordialement,
D.

Debrief
 Posté le 27/09/2019 à 13:41 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

Si tu veux une méthode efficace de colorisation de la ligne sélectionnée, tu peux essayer ce code initialement copié de notre regretté Ferrand, et récemment amélioré pour:
- Générer automatiquement le Nom dans le gestionnaire de nom et la MFC nécessaire,
- Traiter la différenciation de la sélection selon qu'elle est faite par un clic souris ou par un déplacement curseur,
- Ajouter quelques paramètres optionnels dont les valeurs par défaut sont dans des constantes modifiables.

'Constantes modifiables valeurs par défaut des paramètres optionnels du Sub SurligneLigne()
Const NbLignesTitre = 1 'Nombre de lignes titre de la feuille à ne pas surligner
Const SélectionTouches = True 'Accepter ou non la sélection de cellule par les touches clavier
Const SélectionClick = True 'Accepter ou non la sélection de cellule par le clic souris
Const SélectionGarder = False 'Garder ou non la sélection en cours si la nouvelle sélection n'est pas valide
Const ColorSurlignage = 13434879 'Code couleur .Color de surlignage

Il te suffit d'extraire de ce classeur https://www.cjoint.com/c/IIBmGUpZEfN le module Module_SurligneLigne et d'appeler le sub SurligneLigne(Target) dans le Sub Worksheet_SelectionChange de la feuille.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call SurligneLigne(Target)
End Sub

D.



Modifié par Debrief le 27/09/2019 14:32
Debrief
 Posté le 27/09/2019 à 14:47 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Astucien

Je t'ai dit un bêtise concernant ton code actuel...
Il faut mémoriser .Color ET .ColorIndex car .ColorIndex peut aussi prendre les valeurs xlColorIndexAutomatic ou xlColorIndexNone qui ont un rôle important.

Donc ça rend encore plus long le traitement nécessaire au Save et Restore des couleurs des cellules de la ligne sur ue fichier Excel > 2003 !

Option Explicit

Dim Tablo() As Long
Dim iLastR As Long
Dim NbColonnes As Integer

Private Sub Worksheet_Deactivate()
ResetRow
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iR As Long
Dim i As Integer
Dim VersionExcel As Integer

If NbColonnes = 0 Then
VersionExcel = Replace(Application.Version, ".", Application.DecimalSeparator)
If VersionExcel < 12 Then NbColonnes = 256 Else NbColonnes = 16384
ReDim Tablo(1 To NbColonnes, 1 To 2)
End If

iR = Target.Row

Call ResetRow

For i = 1 To NbColonnes
Tablo(i, 1) = Cells(Target.Row, i).Interior.Color
Tablo(i, 2) = Cells(Target.Row, i).Interior.ColorIndex
Next

Rows(iR).Interior.ColorIndex = 38
iLastR = iR
End Sub

Private Sub ResetRow()
Dim i As Integer

If iLastR > 0 Then
For i = 1 To NbColonnes
Cells(iLastR, i).Interior.Color = Tablo(i, 1)
Cells(iLastR, i).Interior.ColorIndex = Tablo(i, 2)
Next
End If
End Sub

gpl85
 Posté le 29/09/2019 à 09:46 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Nouvel astucien
Debrief a écrit :

Je t'ai dit un bêtise concernant ton code actuel...
Il faut mémoriser .Color ET .ColorIndex car .ColorIndex peut aussi prendre les valeurs xlColorIndexAutomatic ou xlColorIndexNone qui ont un rôle important.

Donc ça rend encore plus long le traitement nécessaire au Save et Restore des couleurs des cellules de la ligne sur ue fichier Excel > 2003 !

Option Explicit

Dim Tablo() As Long
Dim iLastR As Long
Dim NbColonnes As Integer

Private Sub Worksheet_Deactivate()
ResetRow
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iR As Long
Dim i As Integer
Dim VersionExcel As Integer

If NbColonnes = 0 Then
VersionExcel = Replace(Application.Version, ".", Application.DecimalSeparator)
If VersionExcel < 12 Then NbColonnes = 256 Else NbColonnes = 16384
ReDim Tablo(1 To NbColonnes, 1 To 2)
End If

iR = Target.Row

Call ResetRow

For i = 1 To NbColonnes
Tablo(i, 1) = Cells(Target.Row, i).Interior.Color
Tablo(i, 2) = Cells(Target.Row, i).Interior.ColorIndex
Next

Rows(iR).Interior.ColorIndex = 38
iLastR = iR
End Sub

Private Sub ResetRow()
Dim i As Integer

If iLastR > 0 Then
For i = 1 To NbColonnes
Cells(iLastR, i).Interior.Color = Tablo(i, 1)
Cells(iLastR, i).Interior.ColorIndex = Tablo(i, 2)
Next
End If
End Sub

Debrief, bonjour,

Merci pour ton nouveau message. La lenteur d'exécution n'est pas un obstacle, ce qui est important c'est de colore en gardant la mise en forme.

Cordialement,

GPL85

Gorfous
 Posté le 29/09/2019 à 12:56 
Aller en bas de la page Revenir au message précédent Revenir en haut de la page
Petit astucien

Salutations

Dim Dligne As Long
Dim MaPlage As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Plage As Range
Application.ScreenUpdating = False
If Target.Cells.Column > 1 Then Exit Sub
EffCouleur
Set Plage = Application.Intersect(MaPlage, Rows(Target.Row))
If Not Plage Is Nothing Then
Plage.Interior.ColorIndex = 36
End If
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Activate()
Application.ScreenUpdating = True
EffCouleur
Application.ScreenUpdating = False
End Sub

Sub EffCouleur()
Dim Ligne As Long
Dligne = Range("A" & Rows.Count).End(xlUp).Row
Set MaPlage = Range("A2:AA" & Dligne)
MaPlage.Interior.ColorIndex = xlNone
For Ligne = 1 To Dligne Step 2
MaPlage.Rows(Ligne).Interior.ColorIndex = 35
Next Ligne
End Sub

Page : [1] 
Page 1 sur 1

Vous devez être connecté pour poster des messages. Cliquez ici pour vous identifier.

Vous n'avez pas de compte ? Créez-en un gratuitement !


Sujets relatifs
Aucun sujet pertinent lié trouvé
 > Tous les forums > Forum Bureautique