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 🙂