XL 2013 Surlignage ligne et colone par clic

nicroq · 2 Juin 2020

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

job75 · 5 Juin 2020

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+

nicroq · 6 Juin 2020

merci a vous pour ttes ces solutions je vais tester tout ca !!!

nicroq · 9 Juin 2020

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

nicroq · 9 Juin 2020

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

fanch55 · 9 Juin 2020

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)

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 .

fanch55 · 9 Juin 2020

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?

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

nicroq · 10 Juin 2020

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

job75 · 10 Juin 2020

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+

fanch55 · 10 Juin 2020

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

XL 2013 Surlignage ligne et colone par clic

nicroq

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

nicroq

XLDnaute Occasionnel

nicroq

XLDnaute Occasionnel

nicroq

XLDnaute Occasionnel

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

nicroq

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

fanch55

XLDnaute Barbatruc

Discussions similaires

XL 2013 Surlignage ligne et colone par clic

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency