Draw square instead of rectangles

[YasserKhalil]

Hello everyone
How can I fix the following code that draws rectangles around the cells ...?

Code: Select all

Sub Test()
    Dim c As Range
    For Each c In ActiveSheet.Range("B3:F3")
        AddShape c
    Next c
End Sub

Sub AddShape(rng As Range)
    rng.Cells(1).Parent.Shapes.AddShape msoShapeRectangle, rng.Left, rng.Top, rng.Width, rng.Height
End Sub

I need to make the shapes as square and to let spaces between those squares ( I mean not to fill the whole cell with the shape) ..

[HansV]

Should the squares be as tall as the cells, or as wide, or ...?

[YasserKhalil]

The shapes would be start at row 3 and may extend to other rows (no problem). The most important to get squares shapes and let spaces in between each suqare

[HansV]

How about

Code: Select all

Sub AddShape(ByVal rng As Range)
    Const f = 0.8 ' You can change this. It must be < 1.
    Dim h As Double, w As Double, t As Double, l As Double, s As Double
    Set rng = rng.Cells(1)
    l = rng.Left
    t = rng.Top
    w = rng.Width
    h = rng.Height
    If w > h Then
        s = h
    Else
        s = f * w
        t = t + (h - s) / 2
    End If
    l = l + (w - s) / 2
    rng.Parent.Shapes.AddShape msoShapeRectangle, l, t, s, s
End Sub

[YasserKhalil]

That's perfect. Thank you very much for awesome solution. I liked it a lot.
What's the benefit of the variable f (not clear for me)..?

[HansV]

It's the factor by which we shrink the square if the height of the cell is larger than its width. If we didn't shrink them, the squares would touch each other.
The side of the square is 80% of the width of the cell. You can change this to (for example) 0.9 if you want less space in between, or to (for example) 0.6 if you want more space in between.

S3502.png

[jstevens]

Hans,

A very nice solution.

[HansV]

Thank you!