Question

我是vba的新手，我正在尝试制作一个宏来绘制范围中每个圆圈的椭圆形我找到了一个在选定单元格中制作椭圆的代码

Sub Add_Oval_in_ActiveCell()
Worksheets("Sheet1").Activate
Range("A1:A6").Select
Range("A2").Activate
t = ActiveCell.Top
l = ActiveCell.Left
h = ActiveCell.Height
w = ActiveCell.Width
    ActiveSheet.Shapes.AddShape(msoShapeOval, l, t, w, h).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
    End With
    With Selection.ShapeRange.Line
    .Visible = msoTrue
    .Weight = 2.25
    End With
End Sub

这可以在细胞A2中绘制一个椭圆形

如何让它在一系列细胞中循环？

提前谢谢

Answer 1

这对于范围内的每个单元格都是椭圆形的：

Sub sof20302984AddOvalInActiveCell()
  Dim t, l, h, w
  Dim aCell
  '
  'Worksheets("Sheet1").Activate
  'Range("A1:A6").Select
  '
  For Each aCell In Range("A1:B6")
    aCell.Activate
    t = ActiveCell.Top
    l = ActiveCell.Left
    h = ActiveCell.Height
    w = ActiveCell.Width
    ActiveSheet.Shapes.AddShape(msoShapeOval, l, t, w, h).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
      .Visible = msoTrue
      .ForeColor.RGB = RGB(255, 0, 0)
      .Transparency = 0
      End With
      With Selection.ShapeRange.Line
      .Visible = msoTrue
      .Weight = 2.25
    End With
  Next
  Set aCell = Nothing
End Sub

Answer 2

'try this one 
Set myDocument = Worksheets(1)
With myDocument.Shapes
    For Z = .Count To 1 Step -1
        With .Item(Z)
            If .Name = "oval" Then .Delete

        End With
    Next
End With



Dim t, l, h, w
  Dim aCell



  '
  For Each aCell In Range("A1:B6")
    aCell.Activate
    t = ActiveCell.Top
    l = ActiveCell.Left
    h = ActiveCell.Height
    w = ActiveCell.Width
    ActiveSheet.Shapes.AddShape(msoShapeOval, l, t, w, h).Select
    Selection.ShapeRange.Name = "oval"
    Selection.ShapeRange.Fill.Visible = msoFalse

    With Selection.ShapeRange.Line
      .Visible = msoTrue
      .ForeColor.RGB = RGB(255, 0, 0)
      .Transparency = 0
      End With
      With Selection.ShapeRange.Line
      .Visible = msoTrue
      .Weight = 2.25
    End With
  Next
 Cells(1, 1).Activate
  Set aCell = Nothing

excel（2010） - 遍历范围中的每个单元格并绘制一个椭圆

2 个答案: