Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Comment positionner un rectangle a l'endroit du curseur?

Comment positionner un rectangle a l'endroit du curseur?

6 réponses
Avatar
Emile63
Bonjour =E0 tous,

Je souhaite ins=E9rer un rectangle =E0 l'endroit ou se trouve la
s=E9lection, qui aurair diff=E9rentes couleurs RGB, en fonction d'un
crit=E8re contenu dans la cellule s=E9lectionn=E9.
Comment faire pour que le rectangle s'aligne et remplisse la cellule
s=E9l=E9ctionn=E9e enti=E8rement.
Je tourne autour de:

Left=3DA
Top=3DB
Width=3DC
Height=3DD
myDocument.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select

Mais je ne trouve pas comment relever l'entroit ou se trouve le
curseur
car la proc=E9dure suit une colonne de nombres .. ActiveCell.Offset(1,
0).Select

Je vous remercie d'avance pour votre aide et conseils,
Cordialement,
Emile
Signaler un problème avec ce contenu

6 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
michdenis
Bonjour

Si l'objectif poursuivi est de créer un rectangle dans la cellule active ???
'---------------------------
with activecell
A = .left
B = .Top
C = .Width
D = .Height
End with
activesheet.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select
'---------------------------



"Emile63" a écrit dans le message de groupe de discussion :

Bonjour à tous,

Je souhaite insérer un rectangle à l'endroit ou se trouve la
sélection, qui aurair différentes couleurs RGB, en fonction d'un
critère contenu dans la cellule sélectionné.
Comment faire pour que le rectangle s'aligne et remplisse la cellule
séléctionnée entièrement.
Je tourne autour de:

Left=A
Top=B
Width=C
Height=D
myDocument.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select

Mais je ne trouve pas comment relever l'entroit ou se trouve le
curseur
car la procédure suit une colonne de nombres .. ActiveCell.Offset(1,
0).Select

Je vous remercie d'avance pour votre aide et conseils,
Cordialement,
Emile
Avatar
LSteph
Bonjour,

Si j'ai bien compris.Supposons une plage où l'on met des nombres de n
à 999999
et que l'on promène le curseur dedans http://cjoint.com/?dlpIJox5uW

'''''dans modulestandard
Public myrSel As Range, myShp As Shape

''''''dans le code de la Feuille Feuil1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a#, b#, c#, d#, i#
On Error Resume Next
myShp.Delete
On Error GoTo 0
With ActiveCell
a = .Left
b = .Top
c = .Width
d = .Height
End With
i = ActiveCell Mod 56

Set myShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, a, b, c, d)
myShp.OLEFormat.Object.Interior.ColorIndex = i
myShp.OLEFormat.Object.Text = ActiveCell
Target.Activate

End Sub

'LSteph




On 11 mar, 13:23, Emile63 wrote:
Bonjour à tous,

Je souhaite insérer un rectangle à l'endroit ou se trouve la
sélection, qui aurair différentes couleurs RGB, en fonction d'un
critère contenu dans la cellule sélectionné.
Comment faire pour que le rectangle s'aligne et remplisse la cellule
séléctionnée entièrement.
Je tourne autour de:

Left=A
Top=B
Width=C
Height=D
myDocument.Shapes.AddShape(msoShapeRectangle, A, B, C, D).Select

Mais je ne trouve pas comment relever l'entroit ou se trouve le
curseur
car la procédure suit une colonne de nombres .. ActiveCell.Offset(1,
0).Select

Je vous remercie d'avance pour votre aide et conseils,
Cordialement,
Emile
Avatar
Emile63
Bonjour Michdenis,

Encore tu viens a mon secours, merci pour ton aide assidue :-))
C'était bien le bout de code manquant.. ;-)
Maintenant j'ai un autre problème (de mémoire)...
Il y a env. 220 Rectangles dans ma feuille.
Quand j'éxécute la macro dans un fichier test, elle fonctionne
correctement.
Par-contre quand je la test sur ma feuille de travail, elle
plantouille un peu avec une: erreur de mémoire 7
Voici le code, et ma question c'est:
- Est-ce qu'il y a un moyen de contourner ce problème (éventl. afiner
mon code...)
'**************************************************
Sub Couleurs()
Dim A, B, C, D, E, G, R, MyDocument
'On Error Resume Next
Application.ScreenUpdating = False
Set MyDocument = ActiveSheet
MyDocument.Shapes.SelectAll ' <_ Ici, j'ai -Erreur 7, Mémoire
insufisante.
Selection.Delete ' Du coup, comme il ne sélectionne pas les
"Shapes",
Range("B5").Select ' il ne les effaces pas non plus.
For I = 5 To 250
With ActiveCell
A = .Left 'Gauche
E = .Top 'Haut
C = .Width
D = .Height
End With
If Range("C" & I) = Empty Then Exit Sub
R = Mid(Range("C" & I).Value, 1, 3)
G = Mid(Range("C" & I).Value, 5, 3)
B = Mid(Range("C" & I).Value, 9, 3)
MyDocument.Shapes.AddShape(msoShapeRectangle, A, E, C,
D).Select
With Selection
.ShapeRange.Fill.ForeColor.RGB = RGB(R, G, B)
End With
ActiveCell.Offset(1, 0).Select
Next I
Application.ScreenUpdating = True
End Sub
'**************************************************

Encore merci pour ton aide,
Cordialement,

Emile
Avatar
Emile63
Merci LSteph
Pour ton aide.
C'est pas tout-à-fait ce que le suis en train de boutiquer,
mais ça m'a donné de nouvelles idées... ;-))
Avatar
michdenis
'----------------------------------------------
Sub Couleurs()
Dim A As Double, B As Integer, C As Double
Dim D As Double, E As Double, G As Integer, R As Integer
Dim Rg As Range, Cell As Range

Application.ScreenUpdating = False
With ActiveSheet
'Efface toutes les shapes de la feuille
.DrawingObjects.Delete
'Définit la plage de cellules
Set Rg = .Range("A5:A250")
End With

'Une boucle sur chacune des cellules
For Each Cell In Rg
With Cell
If .Value = Empty Then Exit Sub
A = .Left 'Gauche
E = .Top 'Haut
C = .Width
D = .Height

R = Mid(.Value, 1, 3)
G = Mid(.Value, 5, 3)
B = Mid(.Value, 9, 3)
With .Parent.Shapes.AddShape(msoShapeRectangle, A, E, C, D)
.Fill.ForeColor.RGB = RGB(10, 50, 200)
End With
End With
Next
Application.ScreenUpdating = True
End Sub
'----------------------------------------------




"Emile63" a écrit dans le message de groupe de discussion :

Bonjour Michdenis,

Encore tu viens a mon secours, merci pour ton aide assidue :-))
C'était bien le bout de code manquant.. ;-)
Maintenant j'ai un autre problème (de mémoire)...
Il y a env. 220 Rectangles dans ma feuille.
Quand j'éxécute la macro dans un fichier test, elle fonctionne
correctement.
Par-contre quand je la test sur ma feuille de travail, elle
plantouille un peu avec une: erreur de mémoire 7
Voici le code, et ma question c'est:
- Est-ce qu'il y a un moyen de contourner ce problème (éventl. afiner
mon code...)
'**************************************************
Sub Couleurs()
Dim A, B, C, D, E, G, R, MyDocument
'On Error Resume Next
Application.ScreenUpdating = False
Set MyDocument = ActiveSheet
MyDocument.Shapes.SelectAll ' <_ Ici, j'ai -Erreur 7, Mémoire
insufisante.
Selection.Delete ' Du coup, comme il ne sélectionne pas les
"Shapes",
Range("B5").Select ' il ne les effaces pas non plus.
For I = 5 To 250
With ActiveCell
A = .Left 'Gauche
E = .Top 'Haut
C = .Width
D = .Height
End With
If Range("C" & I) = Empty Then Exit Sub
R = Mid(Range("C" & I).Value, 1, 3)
G = Mid(Range("C" & I).Value, 5, 3)
B = Mid(Range("C" & I).Value, 9, 3)
MyDocument.Shapes.AddShape(msoShapeRectangle, A, E, C,
D).Select
With Selection
.ShapeRange.Fill.ForeColor.RGB = RGB(R, G, B)
End With
ActiveCell.Offset(1, 0).Select
Next I
Application.ScreenUpdating = True
End Sub
'**************************************************

Encore merci pour ton aide,
Cordialement,

Emile
Avatar
Emile63
Bonjour Michdenis,

Une fois encore t'as mis dans le mille. :-)

Mille mercis.
cordialement,
Emile