XL 2010 [RESOLU]Adapter Dimensions Shapes d'une plage

cathodique

cathodique

XLDnaute Barbatruc
Bonjour,

J'ai trouvé un code de Gaëtan Mourmont que vous trouverez sur la 1ère feuille.
Sur une seconde feuille, je voudrais adapter son code pour que les dimensions des 2 shapesRectangles s'adaptent à la ligne et à la colonne d’entêtes.
Vous comprendrez rapidement en ouvrant le fichier joint.
Présentement, au clic dans une cellule de la plage, un rectangle vertical apparait au-dessus de la cellule jusqu'à la 1ère ligne de la feuille
et un second horizontal à gauche de la cellule jusqu'à la 1ère colonne de la feuille. Je voudrais qu'ils s'arrêtent à la ligne et colonne de titre.
En espérant que mes explications sont claires. J'édite le code pour ceux et celles qui ne veulent pas ouvrir le fichier
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' Macro créée par G.Mourmant le 01/09/2001
'http://www.polykromy.com/nl/nl6/nl6.html
'Stop
'*** Définition des variables ***
   h = ActiveCell.Height
   w2 = ActiveCell.Width
   t = ActiveCell.Top
   w = ActiveCell.Left
Debug.Print ActiveCell.Address, "h=" & h, "w2=" & w2, "t=" & t, "w=" & w
If Not Application.Intersect(Target, [D6:N20]) Is Nothing Then
   'Teste si les rectangles existent déjà.
   On Error Resume Next
   ActiveSheet.Shapes("RectangleV").Delete
   On Error Resume Next
   ActiveSheet.Shapes("RectangleH").Delete
   On Error GoTo 0

   'Ajoute les rectangles
   ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, t, w, h).Name = "RectangleH"
   With ActiveSheet.Shapes("RectangleH")
      .Fill.Visible = msoFalse
      .Fill.Transparency = 0#
      .Line.Weight = 2# '3#
      .Line.ForeColor.SchemeColor = 3 '10
      .ControlFormat.PrintObject = False
   End With

   ActiveSheet.Shapes.AddShape(msoShapeRectangle, w, 0, w2, t).Name = "RectangleV"

   With ActiveSheet.Shapes("RectangleV")
      .Fill.Visible = msoFalse
      .Fill.Transparency = 0#
      .Line.Weight = 3#
      .Line.ForeColor.SchemeColor = 10
      .ControlFormat.PrintObject = False
   End With

End If
End Sub
Avec mes remerciements anticipés.
 

Pièces jointes

  • rectangle.xlsm
    36.4 KB · Affichages: 5
Dernière édition:
Solution
Dranreb
Vous pouvez mettre dans un module standard :
VB: 
Public Sub RectanglesHV(ByVal Target As Range, ByVal RngZone As Range)
   Dim Wsh As Worksheet
   Set Wsh = RngZone.Worksheet
   If Intersect(Target, RngZone) Is Nothing Then
      Wsh.Shapes("RectangleV").Visible = False
      Wsh.Shapes("RectangleH").Visible = False
   Else
      With Wsh.Shapes("RectangleV")
         .Left = Target.Left
         .Top = RngZone.Top
         .Width = Target.Width
         .Height = Target.Top - .Top
         .Visible = True: End With
      With Wsh.Shapes("RectangleH")
         .Left = RngZone.Left
         .Top = Target.Top
         .Width = Target.Left - .Left
         .Height = Target.Height
         .Visible = True: End With
      End If
   End...
Trier par date Trier par votes
sousou

sousou

XLDnaute Barbatruc
bonjour
Pour la seconde feuille.
, mais si tu dois utilsier ça souvent, une procédure adapter à n'importqu'eulle tableau serait mieux
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' Macro créée par G.Mourmant le 01/09/2001
'http://www.polykromy.com/nl/nl6/nl6.html
'Stop
'*** Définition des variables ***

w = ActiveCell.Width
h = ActiveCell.Height
t = ActiveCell.Top
l = ActiveCell.Left
dw = Cells(5, 4).Left
w1 = ActiveCell.Offset.Left - dw

dh = Cells(6, 6).Top
h1 = ActiveCell.Top - dh

Debug.Print ActiveCell.Address, "h=" & h, "w2=" & w2, "t=" & t, "w=" & w
If Not Application.Intersect(Target, [D6:N20]) Is Nothing Then
'Teste si les rectangles existent déjà.
On Error Resume Next
ActiveSheet.Shapes("RectangleV").Delete
On Error Resume Next
ActiveSheet.Shapes("RectangleH").Delete
On Error GoTo 0

'Ajoute les rectangles
ActiveSheet.Shapes.AddShape(msoShapeRectangle, dw, t, w1, h).Name = "RectangleH"
With ActiveSheet.Shapes("RectangleH")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 2# '3#
.Line.ForeColor.SchemeColor = 3 '10
.ControlFormat.PrintObject = False
End With

ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, dh, w, h1).Name = "RectangleV"

With ActiveSheet.Shapes("RectangleV")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.ControlFormat.PrintObject = False

End With

End If
End Sub
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
sousou à dit:
bonjour
Pour la seconde feuille.
, mais si tu dois utilsier ça souvent, une procédure adapter à n'importqu'eulle tableau serait mieux
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' Macro créée par G.Mourmant le 01/09/2001
'http://www.polykromy.com/nl/nl6/nl6.html
'Stop
'*** Définition des variables ***

w = ActiveCell.Width
h = ActiveCell.Height
t = ActiveCell.Top
l = ActiveCell.Left
dw = Cells(5, 4).Left
w1 = ActiveCell.Offset.Left - dw

dh = Cells(6, 6).Top
h1 = ActiveCell.Top - dh

Debug.Print ActiveCell.Address, "h=" & h, "w2=" & w2, "t=" & t, "w=" & w
If Not Application.Intersect(Target, [D6:N20]) Is Nothing Then
'Teste si les rectangles existent déjà.
On Error Resume Next
ActiveSheet.Shapes("RectangleV").Delete
On Error Resume Next
ActiveSheet.Shapes("RectangleH").Delete
On Error GoTo 0

'Ajoute les rectangles
ActiveSheet.Shapes.AddShape(msoShapeRectangle, dw, t, w1, h).Name = "RectangleH"
With ActiveSheet.Shapes("RectangleH")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 2# '3#
.Line.ForeColor.SchemeColor = 3 '10
.ControlFormat.PrintObject = False
End With

ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, dh, w, h1).Name = "RectangleV"

With ActiveSheet.Shapes("RectangleV")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.ControlFormat.PrintObject = False

End With

End If
End Sub
Cliquez pour agrandir...
Bonjour @sousou ;),

Je te remercie pour ton retour. Tu aurais dû éditer la procédure de Gaëtan Mourmont qui est déjà dans le fichier joint entre côte </> de la barre de menu du fil.
Tu n'as compris mes explications. Désolé, des fois je deviens nul. C'est sûrement pour cela que tu viens de rééditer le code du fichier que j'ai joint.
En fait, je voudrais adapter le code de Gaëtan pour une plage de données ou un tableau.
Le code initial proposé s'appliquer à toutes les cellules de la feuille. C'est à dire les rectangles apparaissent même si la cellule cliquait est hors du tableau.
J'ai ajouté cette ligne pour que la procédure ne s’exécute que pour une plage précise, dans mon exemple "D6:N20".
VB: 
If Not Application.Intersect(Target, [D6:N20]) Is Nothing Then
Mais les rectangles s'étendent jusqu’à la 1ère ligne (sens vers le haut) et 1ère colonne (sens vers la gauche). C'est ce que je veux éviter, les rectangles doivent rester à l'intérieur de la plage ou du tableau.
L'objectif est d'avoir un code générique applicable à n'importe quelle plage ou tableau.

Encore merci.
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour.
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
   If Intersect(Me.[D6:N20], Target) Is Nothing Then Exit Sub
   With Me.Shapes("RectangleV")
      .Left = Target.Left
      .Top = Rows(6).Top
      .Width = Target.Width
      .Height = Target.Top - .Top: End With
   With Me.Shapes("RectangleH")
      .Left = Columns("D").Left
      .Top = Target.Top
      .Width = Target.Left - .Left
      .Height = Target.Height: End With
   End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Dranreb à dit:
Bonjour.
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
   If Intersect(Me.[D6:N20], Target) Is Nothing Then Exit Sub
   With Me.Shapes("RectangleV")
      .Left = Target.Left
      .Top = Rows(6).Top
      .Width = Target.Width
      .Height = Target.Top - .Top: End With
   With Me.Shapes("RectangleH")
      .Left = Columns("D").Left
      .Top = Target.Top
      .Width = Target.Left - .Left
      .Height = Target.Height: End With
   End Sub
Cliquez pour agrandir...
Bonsoir @Dranreb ;) ,

Je t'avoue que je suis bluffé. Ton code est très simple, je me suis lancé dans des trucs pas possibles.
Mais il n'est pas vraiment générique. En effet, je n'ai défini la plage, tu as donc répondu en rapport avec ce que j'ai mis.
En définissant la plage, je vais essayer de remplacer Rows(6) et Columns("D") en fonction de cette plage.
Avec tous mes remerciements.
Bonne soirée.
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Vous pouvez mettre dans un module standard :
VB: 
Public Sub RectanglesHV(ByVal Target As Range, ByVal RngZone As Range)
   Dim Wsh As Worksheet
   Set Wsh = RngZone.Worksheet
   If Intersect(Target, RngZone) Is Nothing Then
      Wsh.Shapes("RectangleV").Visible = False
      Wsh.Shapes("RectangleH").Visible = False
   Else
      With Wsh.Shapes("RectangleV")
         .Left = Target.Left
         .Top = RngZone.Top
         .Width = Target.Width
         .Height = Target.Top - .Top
         .Visible = True: End With
      With Wsh.Shapes("RectangleH")
         .Left = RngZone.Left
         .Top = Target.Top
         .Width = Target.Left - .Left
         .Height = Target.Height
         .Visible = True: End With
      End If
   End Sub
Et dans le module de l'objet Worksheet simplement ça :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
   RectanglesHV Target, Me.[D6:N20]
   End Sub
 
Vote positif 1 Vote négatif
Solution
cathodique

cathodique

XLDnaute Barbatruc
Pour le partage
VB: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' by Dranreb
   Dim Rng As Range
   Set Rng = Me.[C5:N20]
   If Intersect(Rng, Target) Is Nothing Then Exit Sub
   With Me.Shapes("RectangleV")
      .Left = Target.Left
      .Top = Rng.Rows.Top
      .Width = Target.Width
      .Height = Target.Top - .Top: End With
   With Me.Shapes("RectangleH")
      .Left = Columns("C").Left
      .Left = Rng.Columns.Left
      .Top = Target.Top
      .Width = Target.Left - .Left
      .Height = Target.Height: End With
End Sub

edit: Merci beaucoup, on s'est croisé:cool:
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
Dranreb à dit:
Vous pouvez mettre dans un module standard :
VB: 
Public Sub RectanglesHV(ByVal Target As Range, ByVal RngZone As Range)
   Dim Wsh As Worksheet
   Set Wsh = RngZone.Worksheet
   If Intersect(Target, RngZone) Is Nothing Then
      Wsh.Shapes("RectangleV").Visible = False
      Wsh.Shapes("RectangleH").Visible = False
   Else
      With Wsh.Shapes("RectangleV")
         .Left = Target.Left
         .Top = RngZone.Top
         .Width = Target.Width
         .Height = Target.Top - .Top
         .Visible = True: End With
      With Wsh.Shapes("RectangleH")
         .Left = RngZone.Left
         .Top = Target.Top
         .Width = Target.Left - .Left
         .Height = Target.Height
         .Visible = True: End With
      End If
   End Sub
Et dans le module de l'objet Worksheet simplement ça :
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
   RectanglesHV Target, Me.[D6:N20]
   End Sub
Cliquez pour agrandir...
C'est impeccable pour moi👏. Toute ma gratitude.

👏👏👏👏😎
 
Vote positif 0 Vote négatif

Discussions similaires

Jgral
  • Résolu(e)
XL 2016 Récupération de Valeur de CheckBox (dans un UserForm) et placement dans une zone de texte
Réponses
2
Affichages
1 K
Jgral
Jgral
M
  • Question
Macro active en permanence
Réponses
1
Affichages
871
Dranreb
Dranreb
T
  • Question
Macro avec shapes
Réponses
2
Affichages
681
thireg
T
M
  • Question
Sélection d'une colonne et d'une ligne avec le survol de la souris
Réponses
1
Affichages
1 K
Matjul
M
G
  • Question
Création d'un graphique dans une boucle, pb de dimension et de suppression
Réponses
3
Affichages
1 K
guainflo
G
O
  • Question
erreur d'execution 1004 lors de la protection
Réponses
3
Affichages
2 K
PascalXLD
PascalXLD
M
[REF] Wiki 1 de MichelXld (Généralités Excel)
Réponses
5
Affichages
59 K
Best1
B
T
  • Question
BO perso
Réponses
4
Affichages
1 K
Dan
D
T
  • Question
Barre d'outils Ajout copier coller
Réponses
2
Affichages
1 K
Tial57
T

Membres actuellement en ligne

12 membres et 210 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 095
Messages
2 085 253
Membres
102 837
dernier inscrit
CRETE