> 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 participer à la discussion.
Cliquez ici pour vous identifier.

Vous n'avez pas de compte ? Créez-en un gratuitement !
Recevoir PC Astuces par e-mail


La Lettre quotidienne +226 000 inscrits
Avec l'actu, des logiciels, des applis, des astuces, des bons plans, ...

Les bonnes affaires
Une fois par semaine, un récap des meilleurs offres.

Les fonds d'écran
De jolies photos pour personnaliser votre bureau. Une fois par semaine.

Les nouveaux Bons Plans
Des notifications pour ne pas rater les bons plans publiés sur le site.

Les bons plans du moment PC Astuces

Tous les Bons Plans
17,99 €Micro clé USB 3.1 Sandisk Ultra Fit 128 Go à 17,99 €
Valable jusqu'au 27 Juin

Amazon fait une promotion sur la micro clé USB Sandisk Ultra Fit d'une capacité de 128 Go qui passe à 17,99 €. La minuscule taille de cette clé USB va vous permettre de la laisser brancher en permanence sur votre portable, votre TV ou votre autoradio sans qu'elle dépasse de manière disgracieuse. Sa compatibilité USB 3.1 lui permet d'atteindre des débits jusqu'à 130 Mo/s. 


> Voir l'offre
113,33 €Lego Technic 42110 Land Rover Defender à 113,33 € (via coupon)
Valable jusqu'au 27 Juin

Amazon fait une promotion sur le 42110 Land Rover Defender qui passe à 113,33 € livré gratuitement avec un coupon de réduction à activer sur la page du produit. On le trouve ailleurs à partir de 160 €. Une carrosserie aux lignes authentiques rehaussée des emblèmes de Land Rover, des jantes au design original équipées de pneus qui accrochent à la route, une galerie de toit amovible chargée d’un coffre de rangement, d’une sacoche, d’une échelle et de plaques de désensablement, des portières, un capot et un hayon qui s'ouvrent, ainsi qu'un habitacle détaillé. Les fonctionnalités comprennent une boîte séquentielle à 4 rapports, 4 roues motrices avec 3 différentiels, des suspensions indépendantes sur les deux essieux, un moteur 6 cylindres en ligne détaillé et un treuil fonctionnel. 


> Voir l'offre
56,99 €SSD WD Blue SN550 500 Go (NMVe M.2, 2400 Mo/s) à 56,99 €
Valable jusqu'au 26 Juin

Amazon fait une promotion sur le SSD WD Blue SN550 500 Go (NMVe M.2) qui passe à 56,99 € livré alors qu'on le trouve ailleurs à partir de 75 €. Ce SSD utilise une interface M.2 NVMe PCIe Gen3 x 4 pour une connexion simple et des performances exceptionnelles : jusqu’à 2 400 Mo/s en lecture séquentielle et jusqu’à 1 950 Mo/s en écriture séquentielle. Le SSD est doté de la technologie 3D TLC NAND haute densité offrant une endurance d’écriture durable et assorti d’une garantie de cinq ans. 


> Voir l'offre

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