XL 2013 Surlignage ligne et colone par clic

N

nicroq

XLDnaute Occasionnel
Bonjour a tous,

Voici le code que j'ai complété afin de surligner la ligne et la colonne de la cellule sur laquelle je clique .
Cependant ma problématique est la suivante : est il possible de ne pas surligner l'ensemble de la ligne ou de la colonne mais uniquement dans un zone définie (voir fichier joint feuille 2 si je clique sur K17). Le code est actif en feuille 1.

En vous remerciant par avance
Cordialement


'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
' Clear the color of all the cells
Cells.Interior.ColorIndex = 0
With Target
' Highlight the entire row and column that contain the active cell
.EntireRow.Interior.ColorIndex = 8
.EntireColumn.Interior.ColorIndex = 8
End With
Application.ScreenUpdating = True
'End Sub
 

Pièces jointes

  • test surlignage.xlsm
    16.1 KB · Affichages: 22
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour à tous,

Cette solution utilise 2 Labels (ActiveX) :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim coef#, r As Range, n As Byte
coef = 1.5 'coefficient de zoom, à adapter
'---RAZ---
Label1.Visible = False: Label2.Visible = False
Cells.Borders.LineStyle = xlNone: Cells.Interior.ColorIndex = xlNone 'RAZ
'---bordures---
Set r = Intersect([E2].CurrentRegion.EntireColumn, [B5].CurrentRegion.EntireRow) 'cellules à adaptet
For n = 7 To 10: r.Borders(n).Weight = xlMedium: Next
'---couleurs---
If Intersect(ActiveCell, r) Is Nothing Then Exit Sub
Range(ActiveCell, Cells(r.Row, ActiveCell.Column)).Interior.ColorIndex = 8
Range(ActiveCell, Cells(ActiveCell.Row, r.Column)).Interior.ColorIndex = 8
'---Zoom sur les Labels---
n = 0
For Each r In Union(Intersect(ActiveCell.EntireColumn, [E2].EntireRow), Intersect(ActiveCell.EntireRow, [B5].EntireColumn))
    With IIf(n, Label1, Label2)
        .Caption = r.Text
        .Font.Size = coef * r.Font.Size
        .AutoSize = True
        .Width = coef * r.Width
        .Left = r.Left + (r.Width - .Width) / 2
        .Top = r.Top + (r.Height - .Height) / 2
        .Visible = True
    End With
    n = n + 1
Next
End Sub
A+
 

Pièces jointes

  • test surlignage(1).xlsm
    30.7 KB · Affichages: 21
Vote positif 0 Vote négatif
N

nicroq

XLDnaute Occasionnel
Merci a vous la methode de fanchme plait bien !! par contre si me retrouve avec une cellule fusionnée est il possible de mettre les commentaires au debut et à la fin de la cellule selectionée? ( 4 commentaires au total)
merci
 
Vote positif 0 Vote négatif
N

nicroq

XLDnaute Occasionnel
re bonjour, j'ai une dernière demande.. desolé ... Serait possible que sur la cellule sur laquelle on clique apparaissent un commentaire avec l'intitulé de la colonne 2 suivi de la date de ligne associée?

en vous remerciant sincérement
cordialement
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
nicroq à dit:
si me retrouve avec une cellule fusionnée est il possible de mettre les commentaires au debut et à la fin de la cellule selectionée? ( 4 commentaires au total)
Cliquez pour agrandir...
Je ne comprend pas : un commentaire appartient à une cellule qu'elle soit fusionnée avec d'autres ou non. Quel est l'intérêt de fusionner plusieurs cellules avec la même valeur s'il faut les re décomposer ?
Un exemple serait le bienvenu .
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
nicroq à dit:
re bonjour, j'ai une dernière demande.. desolé ... Serait possible que sur la cellule sur laquelle on clique apparaissent un commentaire avec l'intitulé de la colonne 2 suivi de la date de ligne associée?
Cliquez pour agrandir...
A essayer
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Cells.Count > 1 Then Exit Sub
    
    [E4:O25].ClearComments              'Effacer commentaires plage concernée
    Rows(2).Interior.ColorIndex = 0     'Effacer couleurs ligne 2
    
    Columns(2).ClearComments            'Effacer commentaires colonne 2
    Columns(2).Interior.ColorIndex = 0  'Effacer couleurs colonne 2
    
    [E4:O25].Interior.ColorIndex = 0    'Effacer couleurs cadre
    
    If Not Intersect(Target, Range("E4:O25")) Is Nothing Then
        Application.ScreenUpdating = False
        ' Highlight the entire row and column that contain the active cell
        Range(Cells(Target.Row, 5), Cells(Target.Row, Target.Column)).Interior.ColorIndex = 8
        Range(Cells(4, Target.Column), Cells(Target.Row, Target.Column)).Interior.ColorIndex = 8
        ' Ajout Commentaire
        With Target.AddComment(Cells(Target.Row, 2).Text & vbLf & Cells(2, Target.Column).Text).Shape
            .TextFrame.HorizontalAlignment = xlCenter   ' Alignement horizontal du commentaire
            .TextFrame.VerticalAlignment = xlCenter     ' Alignement vertical du commentaire
            .Fill.ForeColor.RGB = RGB(0, 160, 192)      ' Couleur de fond du commentaire
            .DrawingObject.Font.ColorIndex = 1          ' couleur du Texte 1:Noir 2:Blanc
            .DrawingObject.Font.Name = "Tahoma"         ' Nom de la Police utilisée
            .DrawingObject.Font.Bold = True             ' Police en Gras
            .DrawingObject.Font.Size = 14               ' Taille Police
        End With
        Target.Comment.Visible = True
    End If
  
End Sub
 
Vote positif 0 Vote négatif
N

nicroq

XLDnaute Occasionnel
Bonjour,

dans l' exemple joint le code ne marche pas pour des cellules fusionnée. Dans cet exemple je souhaiterai que lorsque on clique sur la cellule fusionnée que ca mette le commentaire en B8 et en I13 (les bornes de la cellule fusionnée)

J espere etre plus clair avec cet exemple

merci d avance
 

Pièces jointes

  • test surlignage cell merge.xlsm
    23.2 KB · Affichages: 7
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonsoir à tous,

Toujours avec mes 2 labels, voyez ce fichier (2) et la nouvelle macro :
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim coef#, r As Range, n As Byte, a$(), nn&, rr As Range
coef = 1.5 'coefficient de zoom, à adapter
'---RAZ---
Label1.Visible = False: Label2.Visible = False
Cells.Borders.LineStyle = xlNone: Cells.Interior.ColorIndex = xlNone 'RAZ
'---bordures---
Set r = Intersect([E2].CurrentRegion.EntireColumn, [B5].CurrentRegion.EntireRow) 'cellules à adaptet
For n = 7 To 10: r.Borders(n).Weight = xlMedium: Next
'---couleurs---
If Intersect(ActiveCell, r) Is Nothing Then Exit Sub
Range(ActiveCell.MergeArea, Cells(r.Row, ActiveCell.Column)).Interior.ColorIndex = 8
Range(ActiveCell.MergeArea, Cells(ActiveCell.Row, r.Column)).Interior.ColorIndex = 8
For Each r In r
    If r.MergeCells Then If Intersect(r, ActiveCell) Is Nothing Then r.Interior.ColorIndex = 6 'jaune
Next r
'---Zoom sur les Labels---
n = 0
For Each r In Union(Intersect(ActiveCell.MergeArea.EntireColumn, [E2].EntireRow), Intersect(ActiveCell.MergeArea.EntireRow, [B5].EntireColumn)).Areas
    With IIf(n, Label1, Label2)
        ReDim a(r.Count - 1) 'base 0
        nn = 0
        For Each rr In r
            a(nn) = rr.Text
            nn = nn + 1
        Next rr
        .Caption = Join(a, IIf(n, vbLf, "-"))
        .Font.Size = coef * r.Font.Size
        .AutoSize = False
        .Height = coef * r.Height
        If n Then .AutoSize = True
        .Width = coef * r.Width
        If n = 0 Then .AutoSize = True
        .Left = r.Left + (r.Width - .Width) / 2
        .Top = r.Top + (r.Height - .Height) / 2
        .Visible = True
    End With
    n = n + 1
Next r
End Sub
A+
 

Pièces jointes

  • test surlignage(2).xlsm
    31.9 KB · Affichages: 8
Dernière édition:
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Job75 a essayé de cerner le pb, mais les lignes référentes sont en dehors (lignes +1 et -1 ) de la cellule fusionnée. En fait la demande est assez irréaliste, tu veux afficher les croisements des colonnes et des lignes à partir d'une cellule fusionnée, c'est à dire une cellule avec plusieurs colonnes ou lignes au milieu d'autres "normales" ( à mon sens assez improbable) , je ne vois pas trop l'intérêt.
Je donne un autre exemple si cela te convient, mais je doute que ce soit l'objectif,
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Plage As Range
Set Plage = [E5:O15]
'    If Target.Cells.Count > 1 Then Exit Sub
    
    Plage.ClearComments                 'Effacer commentaires plage concernée
    Rows(2).ClearComments               'Effacer commentaires ligne 2
    Rows(2).Interior.ColorIndex = 0     'Effacer couleurs ligne 2
    
    Columns(2).ClearComments            'Effacer commentaires colonne 2
    Columns(2).Interior.ColorIndex = 0  'Effacer couleurs colonne 2
    
    [E4:O25].Interior.ColorIndex = 0    'Effacer couleurs cadre
    
    If Not Intersect(Target.Cells(1), Plage) Is Nothing Then
        Application.ScreenUpdating = False
        ' Mise en surbrillance des cellules de ligne précédant la cellule active
        Range(Cells(Target.Row, Plage.Cells(1).Column), Cells(Target.Row, Target.Column)).Interior.ColorIndex = 8
        ' Mise en surbrillance des cellules de colonne précédant la cellule active
        Range(Cells(Plage.Cells(1).Row, Target.Column), Cells(Target.Row, Target.Column)).Interior.ColorIndex = 8
        ' Ajout Commentaire
        With Target.Cells(1).AddComment(Cells(Target.Row, 2).Text & vbLf & Cells(2, Target.Column).Text).Shape
            .TextFrame.HorizontalAlignment = xlCenter   ' Alignement horizontal du commentaire
            .TextFrame.VerticalAlignment = xlCenter     ' Alignement vertical du commentaire
            .Fill.ForeColor.RGB = RGB(0, 160, 192)      ' Couleur de fond du commentaire
            .DrawingObject.Font.ColorIndex = 1          ' couleur du Texte 1:Noir 2:Blanc
            .DrawingObject.Font.Name = "Tahoma"         ' Nom de la Police utilisée
            .DrawingObject.Font.Bold = True             ' Police en Gras
            .DrawingObject.Font.Size = 14               ' Taille Police
        End With
        Target.Cells(1).Comment.Visible = True
    End If
 
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

U
  • Question
Autres [RÉSOLU] Faire afficher ligne sur tout le classeur par double clic et la faire maquer à l’enregistrement
Réponses
11
Affichages
388
un internaute
U
C
  • Résolu(e)
XL 2016 Remplir automatiquement un tableau d'après des conditions et des valeurs
Réponses
11
Affichages
1 K
ERIC S
ERIC S
R
  • Question
RVlalanne
Réponses
1
Affichages
713
fanfan38
fanfan38
V
  • Résolu(e)
Microsoft 365 Afficher filtres appliqués par macro dans la cellule B3 directement et non par F5 puis Réinitialiser
Réponses
12
Affichages
990
VirginieG
V
S
  • Résolu(e)
XL 2013 [VBA] Coloration ligne tableau excel
Réponses
2
Affichages
613
STARRAG
S
G
  • Question
XL 2019 Changement type fenêtre pour sélection chemin dossier VBA
Réponses
0
Affichages
760
guiboubou233
G
C
  • Résolu(e)
XL 2019 Supprimer la 1000eme ligne et classer lignes par dates
Réponses
2
Affichages
612
chris4785478547
C
F
  • Question
cellule non vide avant changement de ligne
Réponses
1
Affichages
496
vgendron
vgendron
S
  • Question
XL 2013 Diviser classeur en plusieur fichier et les enregistrer en PDF
Réponses
12
Affichages
1 K
soffianne
S
C
  • Question
CREATION DE PLUSIEURS TCD VBA
2
Réponses
23
Affichages
3 K
Charles78
C

Membres actuellement en ligne

12 membres et 110 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 084
Messages
2 085 190
Membres
102 809
dernier inscrit
Sandrine83