Nommer suite de shape

[Noopy123]

Bonjour,

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

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]

Voilà la solution

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]

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]

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]

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]

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)

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]

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]

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]

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]

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]

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]

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