CODEWITHSUNDEEP
vbaexcel
prestan
prestan

Reputation: 63

Macro Excel: To insert a circle into specific range in cell

I have a circle that has a fixed diameter and center. What I need to do now is to insert the circle into the given range. Eg, given 11 boxes of column and 10 boxes of rows to be inserted in excel cell. After entering the given range, the circle will be within the selected range with its fixed center but the boxes would have different measurement for its height and width. My question is how do I insert the circle into any given range (as in 11 x 10 or 9 x 12) with different height and width of the cells?

My code:

Sub DrawCircleWithCenter()
Dim cellwidth As Single
Dim cellheight As Single
Dim ws As Worksheet
Dim rng As Range
Dim Shp2 As Shape


CellLeft = Selection.Left
CellTop = Selection.Top

ActiveSheet.Shapes.AddShape(msoShapeOval, CellLeft, CellTop, 565 / 2, 565 / 2).Select
Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(0, 0, 0)
    .Transparency = 0
End With

i = 182
Set Shp2 = ActiveSheet.Shapes.AddShape(i, CellLeft, CellTop, 20, 20)
Shp2.ShapeStyle = msoShapeStylePreset1
Set rng = ActiveWindow.VisibleRange

Selection.Left = rng.Width / 2 - Selection.Width / 2
Selection.Top = rng.Height / 2 - Selection.Height / 2
Shp2.Left = rng.Width / 2 - Shp2.Width / 2
Shp2.Top = rng.Height / 2 - Shp2.Height / 2


End Sub

Upvotes: 0

Views: 3340

Answers (1)

Amorpheuses
Amorpheuses

Reputation: 1423

If I'm understanding you correctly this could be what you're after:

Sub DrawCircleWithCenter(rng As Range)
  Dim Shp1 As Shape, Shp2 As Shape

  Set Shp1 = ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, rng.Width, rng.Height)
  Shp1.Fill.Visible = msoFalse
  With Shp1.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(0, 0, 0)
    .Transparency = 0
  End With

  Set Shp2 = ActiveSheet.Shapes.AddShape(182, rng.Left, rng.Top, 20, 20)
  Shp2.ShapeStyle = msoShapeStylePreset1

  Shp1.Left = rng.Left
  Shp1.Top = rng.Top
  Shp2.Left = rng.Left + rng.Width / 2 - Shp2.Width / 2
  Shp2.Top = rng.Top + rng.Height / 2 - Shp2.Height / 2
End Sub

Sub Test()
  Dim rng As Range
  Set rng = Selection
  DrawCircleWithCenter rng
End Sub

You can modify the Test subroutine to supply the range you're after. In the above case I use the selection that the user has highlighted in the present worksheet to draw the cross and oval centered inside it. If you choose a square area the oval becomes a circle, with a rectangular area it'll be squashed into an ellipse. It'll also work if you have varying cell widths and heights in the range you select.

Upvotes: 1

Related Questions