XL 2019 Cellule en surbrillance suivant deux autres cellules.

[Paulle]

Bonsoir,
Si possible, je sélectionne une cellule en colonne "A" elle reste en surbrillance.
Ensuite, je sélectionne une cellule en ligne "2" elle reste en surbrillance.
Et la cellule à l'intersection devra se mettre en surbrillance.
Exemple : A7 et H2 = H7.

J'ai bien trouvé du code VBA, mais ça ne correspond pas à ce que je souhaite.

 

[sylvanu]

Bonsoir Paulle,
Un essai en PJ.
Il faut cliquer en ligne 1:4 ou colonne A pour que les clics soient pris en compte. Avec :

Option Explicit
Public L%, C% ' De public de façon à mémoriser L et C cliquées auparavant.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    If Target.Row <= 4 Then C = Target.Column
    If Target.Column = 1 Then L = Target.Row
    Cells.Interior.ColorIndex = 0
    Cells.Font.Bold = False
    If L > 0 Then Rows(L).Interior.ColorIndex = 8
    If C > 0 Then Columns(C).Interior.ColorIndex = 8
    If L > 0 And C > 0 Then
        Cells(L, C).Interior.Color = RGB(255, 255, 0)
        Cells(L, C).Font.Bold = True
    End If
    Application.ScreenUpdating = True
End Sub

 

[job75]

Bonsoir Paulle, sylvanu,

Création d'une MFC sur une sélection multiple de 2 cellules :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c1 As Range, c2 As Range
Cells.FormatConditions.Delete 'RAZ
Set c1 = Intersect(Selection, UsedRange, UsedRange.Columns(1).Offset(3))
Set c2 = Intersect(Selection, UsedRange, UsedRange.Rows(1).Offset(, 3))
If c1 Is Nothing Or c2 Is Nothing Then Exit Sub
If c1.Count * c2.Count > 1 Then Exit Sub
With Union(c1, c2, Intersect(c1.EntireRow, c2.EntireColumn))
    .FormatConditions.Add xlExpression, Formula1:=1
    .FormatConditions(1).Interior.ColorIndex = 8 'vert
End With
End Sub

A+

 

[mapomme]

Bonjour à tous,

Une autre version :

Option Explicit
Dim ligne&, colonne&

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Application.ScreenUpdating = False
   If Target.Count > 1 Then Exit Sub
   If Intersect(Range("a1").CurrentRegion, Target) Is Nothing Then Exit Sub
   If Target.Column <= 3 Then
      Range("a1").CurrentRegion.Cells.Interior.ColorIndex = xlColorIndexNone
      If Target.Row > 4 Then Range("a1").CurrentRegion.Rows(Target.Row).Interior.Color = vbMagenta
      ligne = Target.Row
      colonne = 0
   End If
   If Target.Row <= 4 Then
      Range("a1").CurrentRegion.Cells.Interior.ColorIndex = xlColorIndexNone
      If Target.Column > 3 Then Range("a1").CurrentRegion.Columns(Target.Column).Interior.Color = vbMagenta
      colonne = Target.Column
   End If
   If ligne > 4 And colonne > 3 Then
      Range("a1").CurrentRegion.Cells.Interior.ColorIndex = xlColorIndexNone
      Cells(ligne, colonne).Interior.Color = vbMagenta
   End If
   If ligne > 4 Then Cells(ligne, "a").Interior.Color = vbYellow
   If colonne > 3 Then Cells(2, colonne).Interior.Color = vbYellow
End Sub

 

[Paulle]

Bonjour à tous,
Les trois versions fonctionnent très bien.

sylvanu, j'aurai préféré que ce soit uniquement les cellules qui soient en surbrillances et non la ligne et colonne.

job75, peut-être sans la touche contrôle.

mapomme, peut-être sans la ligne en surbrillance, uniquement la cellule.

Merci à vous trois pour le temps que vous m'avez consacré. Et en suivant pas à pas, cela me permet de comprendre.

 

[sylvanu]

Bonjour

j'aurai préféré que ce soit uniquement les cellules qui soient en surbrillances et non la ligne et colonne.

Voir PJ.
J'avais simplement essayé de rester au plus proche de votre fichier.

 

[Paulle]

Merci encore, c'est parfait.

 

[job75]

Bonjour Paulle, le forum,

job75, peut-être sans la touche contrôle.

Testez avec ceci :

Dim adr(1 To 2) 'mémorise la variable

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c1 As Range, c2 As Range
Cells.FormatConditions.Delete 'RAZ
adr(2) = adr(1) 'rotation
adr(1) = ActiveCell.Address
If adr(2) = "" Then adr(2) = "A1"
Set c1 = Intersect(Union(Range(adr(1)), Range(adr(2))), UsedRange, UsedRange.Columns(1).Offset(3))
Set c2 = Intersect(Union(Range(adr(1)), Range(adr(2))), UsedRange, UsedRange.Rows(1).Offset(, 3))
If Not c1 Is Nothing Then MFC c1
If Not c2 Is Nothing Then MFC c2
If Not c1 Is Nothing And Not c2 Is Nothing Then MFC Intersect(c1.EntireRow, c2.EntireColumn)
End Sub

Sub MFC(c As Range)
c.FormatConditions.Add xlExpression, Formula1:=1
c.FormatConditions(1).Interior.ColorIndex = 8 'vert
End Sub

A+

 

[Paulle]

Bonjour job,
Cela fonctionne,
Mais si je clique sur une 1ère et une deuxième cellule dans la ligne ou la colonne, la 1ère cellule reste en surbrillance.
Merci.

 

[job75]

Mais si je clique sur une 1ère et une deuxième cellule dans la ligne ou la colonne, la 1ère cellule reste en surbrillance.

D'accord, utilisez :

Dim adr(1 To 2) 'mémorise la variable

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c1 As Range, c2 As Range
Cells.FormatConditions.Delete 'RAZ
adr(2) = adr(1) 'rotation
adr(1) = ActiveCell.Address
If adr(2) = "" Then adr(2) = "A1"
If Range(adr(2)).Row = Range(adr(1)).Row Or Range(adr(2)).Column = Range(adr(1)).Column Then adr(2) = "A1"
Set c1 = Intersect(Union(Range(adr(1)), Range(adr(2))), UsedRange, UsedRange.Columns(1).Offset(3))
Set c2 = Intersect(Union(Range(adr(1)), Range(adr(2))), UsedRange, UsedRange.Rows(1).Offset(, 3))
If Not c1 Is Nothing Then MFC c1
If Not c2 Is Nothing Then MFC c2
If Not c1 Is Nothing And Not c2 Is Nothing Then MFC Intersect(c1.EntireRow, c2.EntireColumn)
End Sub

Sub MFC(c As Range)
c.FormatConditions.Add xlExpression, Formula1:=1
c.FormatConditions(1).Interior.ColorIndex = 8 'vert
End Sub

 

[Paulle]

Merci job. Parfait.