Nommer suite de shape

Noopy123 · 26 Avril 2020

Bonjour,

J'ai une suite de shape rectangle qui se créé selon le code suivant :

VB:

x = ActiveCell.Row               ' définit la ligne de la cellule active
y = ActiveCell.Column           ' définit la colonne de la cellule active
For L = x To x + 5              ' 8 est le nombre de rectangles en X
    For C = y To y + 5          ' 5 est le nombre de rectangles en Y
        With Cells(L, C)
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, .Left, .Top, .Width, .Height).Select
            Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
              
             End With
        
    Next C
Next L

J’aimerais pourvoir nommer les rectangles créés ,via ce code, avec la cellules dans lequel ils paraissent (sachant que la cellule est aléatoire en fonction de la cellule sélectionnée , ... Mais impossible de trouver la solution
Sinon a Default de leur donner les nom 1,2,3,4....

Merci par avance pour votre aide

Noopy123 · 26 Avril 2020

Voilà la solution

VB:

If TypeName(Selection) = "Range" Then
Set Grille = Selection.Item(1).Resize(1, 5)
Grille.RowHeight = 50: Grille.ColumnWidth = 6
With ActiveSheet
    For Each c In Grille
    Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height)
    shp.Line.ForeColor.RGB = RGB(0, 0, 0)
    shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
    shp.Name = "Rect_" & c.Address(0, 0)
    shp.Placement = xlFreeFloating

    Next
End With
End If

Set Base = Selection.Item(1).Resize(2, 5)
Base.RowHeight = 50: Base.ColumnWidth = 4.91

Noopy123 · 26 Avril 2020

Par contre petite question , j'en profite parce que je vais en avoir besoin à un moment.
Comment faire avec ton code pour créer un rectangle qui prend 2 cellules ?

Staple1600 · 26 Avril 2020

Re

Tu disais

J'essaie de l'adapter afin que le code me génère une forme de 6 rectangle sur 6 rectangle

C'est ce que faisait mon code du message#10

PS: Sinon, jamais tu n'adresses un petit merci à ceux qui t'aident ?
(Car j'en vois aucun dans ce fil...)
NB:Je ne compte pas celui du 1er message qui n'est pas nominatif

Noopy123 · 26 Avril 2020

Oups, effectivement j'ai oublié le merci
Alors un grand Merci
Oui c'était le cas pour la première forme mais j'ai besoin d'adapter le code pour correspondre au forme de l'userform ci dessus

Staple1600 · 26 Avril 2020

Re

Si j'étais, je m’intéresserai à la fusion de cellules.
Voir l'exemple ci-dessous
(ce n'est donc qu'un exemple, pas une solution finalisée)

VB:

Sub Grille_POUR_TEST()
Dim c As Range, m As Range, Grille As Range, shp As Shape
If TypeName(Selection) = "Range" Then
Set Grille = Selection.Item(1).Resize(6, 6)
Grille.RowHeight = 50: Grille.ColumnWidth = 4.86
Grille(6, 4).Resize(, 3).Merge: Grille(4, 1).Resize(, 2).Merge
Grille(4, 3).Resize(, 2).Merge: Grille(4, 5).Resize(, 2).Merge
Grille(6, 1).Resize(, 3).Merge: Grille(2, 2).Resize(, 2).Merge
With ActiveSheet
For Each c In Grille
If c.MergeCells Then
Set m = c(1).MergeArea
Set shp = .Shapes.AddShape(1, m.Left, m.Top, m.Width, m.Height)
shp.Line.ForeColor.RGB = RGB(192, 0, 0): shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
shp.Name = "Rect_" & c(1).MergeArea.Address(0, 0)
Else
Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height)
shp.Line.ForeColor.RGB = RGB(192, 0, 0): shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
shp.Name = "Rect_" & c.Address(0, 0)
End If
Next
End With
End If
End Sub

Noopy123 · 26 Avril 2020

Génial l'idée de la fusion, je n'avais pas pensé à ça ! Merci beaucoup j'ai réussi à créer toutes mes formes et en plus à les nommer

Par contre sais-tu pourquoi ça me créé 2 rectangle sur la zone sélectionnée au lieu de 1. Rien de très dérangeant mais c'est au cas où ^^

Staple1600 · 26 Avril 2020

Re

Rebelote

Génial l'idée de la fusion, je n'avais pas pensé à ça ! Merci beaucoup j'ai réussi à créer toutes mes formes et en plus à les nommer

Reparlons encore une fois d'usage...
Un autre usage, c'est de publier dans sa discussion la dernière mouture de son code (ou de sa formule)
Toujours dans l'idée que cela profite à tout le forum.
Dommage qu'il faille "rabâcher" une seconde fois ce que j'avais déjà suggéré au message#15.

Noopy123 · 26 Avril 2020

VB:

Private Sub CommandButton3_Click()
Dim c As Range, m As Range, Grille As Range, shp As Shape
If TypeName(Selection) = "Range" Then
Set Grille = Selection.Item(1).Resize(6, 6)
Grille.RowHeight = 50: Grille.ColumnWidth = 4.91
Grille(4, 1).Resize(, 2).Merge
Grille(4, 3).Resize(, 2).Merge
Grille(4, 5).Resize(, 2).Merge
With ActiveSheet
For Each c In Grille
If c.MergeCells Then
Set m = c(1).MergeArea
Set shp = .Shapes.AddShape(1, m.Left, m.Top, m.Width, m.Height)
shp.Line.ForeColor.RGB = RGB(192, 0, 0): shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
shp.Name = "Rect_" & c.Address(0, 0)
Else
Set shp = .Shapes.AddShape(1, c.Left, c.Top, c.Width, c.Height)
shp.Line.ForeColor.RGB = RGB(192, 0, 0): shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
shp.Name = "Rect_" & c.Address(0, 0)
End If
Next
End With
End If

Grille(1).Resize(6, 6).MergeCells = False

End Sub

Il s'agit d'un vulgaire copier coller légèrement transformé

Noopy123 · 26 Avril 2020

Noopy123 à dit:
Par contre sais-tu pourquoi ça me créé 2 rectangle sur la zone sélectionnée au lieu de 1. Rien de très dérangeant mais c'est au cas où ^^

Par contre pour ce problème je n'ai pas trouvé la solution

Staple1600 · 26 Avril 2020

Re

•>Noopy123
Ne constatant ce que tu décris, je n'ai pas ce problème.
Donc pas de solution à trouver par conséquent.

Noopy123 · 27 Avril 2020

Ce n'est pas grave, ce n'est pas un soucis majeur .
Merci en tout cas

Nommer suite de shape

Noopy123

XLDnaute Junior

Noopy123

XLDnaute Junior

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Noopy123

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Noopy123

XLDnaute Junior

Discussions similaires