Autres Excel et le dessin de formes.

[OlivGM]

Bonjour à tous,

Excel peut-il dessiner des formes (carré ou rectangle), en respectant les mm donnés en saisie, et quelles que soient la largeur des colonnes ou hauteur des lignes?
(si on modifie hauteur ou largeur, il réadapterait la taille du ou des dessins (jusqu'à 6 par feuille)

Merci de votre aide et bon am.

oliv'GM

 

[Nicolas JACQUIN]

Bonjour,
essai ça, à adapter

Sub Ajoute_une_forme_automatique()
    Posh = Range("A2").Left
    Posv = Range("A2").Top
    LWidth = Range("A2").Width
    HHeight = Range("A2").Height
With Worksheets("Feuil1").Shapes.AddShape(msoShapeRectangle, Posh, Posv, LWidth, HHeight)
    .Name = "NomForme"
    .TextFrame.Characters.Text = "Le texte dans la forme"
End With
End Sub

 

[Nicolas JACQUIN]

En ce basant sur tes cellules colorées
Avoir si ça convient

Function PosSh(rng As Range)
Dim Posh As Double, Posv As Double, Wwidth As Double, Hheight As Double
Posh = rng.Left: Posv = rng.Top: LWidth = rng.Width: Hheight = rng.Height
    With Worksheets("Feuil1").Shapes.AddShape(msoShapeRectangle, Posh, Posv, LWidth, Hheight)
        .Name = "NomForme"
        .TextFrame.Characters.Text = "Le texte"
    End With
End Function

Sub Test()
Dim lig As Long, i As Long, j As Long
lig = 2
For i = lig To 6
    PosSh Range("A" & lig)
    PosSh Range("B" & lig)
lig = lig + 1
Next i
For j = 1 To 6: PosSh Range("F" & j): Next j
End Sub

 

[Staple1600]

Bonsoir le fil

Juste 2 minutes avant le couvre-feu
(faut bien s'occuper )

Sub DesFormesEtDesTeintesPourDétente()
Dim rng As Range, shp As Shape, i&, j&
Randomize 1600
For i = 1 To 3
    For j = 1 To 6
    Set rng = Cells(i, j)
    With rng
        Set shp = ActiveSheet.Shapes.AddShape(1, .Left, .Top, .Width, .Height)
        shp.Fill.ForeColor.RGB = RGB(Int(255 * Rnd), Int(255 * Rnd), Int(255 * Rnd))
        shp.TextFrame2.TextRange.Text = "TEST"
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    End With
    Next j
Next i
End Sub

 

[OlivGM]

Bonjour,
Bonne occupation pendant le couvre feu !!
Nicolas Jacquin, ta macro me renvoie "texte" dans toutes les cellules colorées?

a+

 

[Nicolas JACQUIN]

Bonjour à tous,
Vous devez parler du code de Staple1600,
suffit de supprimer ou modifier cette ligne

shp.TextFrame2.TextRange.Text = "TEST"

ou sur mon code

.TextFrame.Characters.Text = "Le texte"

A suivre

 

[Modeste geedee]

Bonsour®

Bonjour à tous,

Excel peut-il dessiner des formes (carré ou rectangle), en respectant les mm donnés en saisie, et quelles que soient la largeur des colonnes ou hauteur des lignes?
(si on modifie hauteur ou largeur, il réadapterait la taille du ou des dessins (jusqu'à 6 par feuille)

Merci de votre aide et bon am.

oliv'GM

Sub position_Shape()
Dim rng As Range, shp As Shape, Ligne&, Colonne&
ActiveSheet.DrawingObjects.Select
Selection.Delete
For Ligne = 2 To 5 
    Set rng = Cells(Cells(Ligne, 3), Cells(Ligne, 4))
    With rng
        Set shp = ActiveSheet.Shapes.AddShape(1, _
                .Left, _
                .Top, _
                Application.CentimetersToPoints(Cells(Ligne, 1) / 10), _
                Application.CentimetersToPoints(Cells(Ligne, 2) / 10))                
        shp.TextFrame.Characters.Text = shp.TopLeftCell.Address
        shp.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = vbRed
        shp.Fill.Visible = msoFalse
    End With
Next Ligne
End Sub

 

[Staple1600]

Bonsoir le fil

[Précisions]
J'aurai du préciser que ma macro n'était qu'une macro de test (à vocation illustrative)
J'ai cru que le nom de la macro le laissait aisément deviner
D'autant qu'elle ne réponds pas au problème posé en message#1, ce que fait le code du message#7.
Mais comme le couvre-feu est encore loin, ce soir j'écris mon message plus posément et je prends de le temps de réfléchir
(enfin c'est que je crois )

 

[OlivGM]

Bonsoir à tous, merci Modeste pour ton fichier qui est parfait.

Bonne soirée