Question

我目前正在尝试从引用的列表中自动创建和命名多个对象，而不是仅在脚本中声明对象文本。

我使用下面的脚本，最好的方法是安排代码以便于添加许多对象以及不要将对象放在同一位置。

设置位置的代码是_ 设置shp = ActiveSheet.Shapes.AddShape（msoShapeRectangle，50,50,100,50）设置对象位置，

如何更改代码以重复多个项目，命名并排列在一起。

 Sub Sample()
     Dim shp As Shape

     Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 50)

     With shp.OLEFormat.Object
         .Formula = ""

         .ShapeRange.ShapeStyle = msoShapeStylePreset40

         .ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
         ThisWorkbook.Sheets("Process Steps").Range("C7").Value
     End With
 End Sub

Answer 1

这里是一个简单的例子，它读取单元格范围并在一行中插入每个单元格的形状。

Option Explicit

Sub main()
    Dim referencedList As Range
    Set referencedList = ThisWorkbook.Sheets("Process Steps").Range("C1:C500")
    Sample referencedList
End Sub

Sub Sample(referencedList As Range)
    Dim shp As Shape
    Dim oneCell As Range
    Dim leftValue As Long

    Const topValue As Integer = 50
    Const widthValue As Integer = 100
    Const heightValue As Integer = 50
    leftValue = 0

    For Each oneCell In referencedList.Cells
        If oneCell.Value = "" Then _
            GoTo continue

        Set shp = ActiveSheet.Shapes.AddShape( _
            msoShapeRectangle, leftValue, topValue, widthValue, heightValue)

        With shp.OLEFormat.Object
            .Formula = ""
            .ShapeRange.ShapeStyle = msoShapeStylePreset40
            .ShapeRange(1).TextFrame2.TextRange.Characters.Text = oneCell.Value
        End With

        leftValue = leftValue + widthValue
continue:
    Next oneCell
 End Sub

从集合列表中自动创建多个对象和名称

1 个答案: