从一个列表中自动创build多个对象和名称

我目前正试图自动创build和命名引用列表中的多个对象，而不是只有在脚本中陈述的对象文本。

即时通讯使用下面的脚本，最好的方式来安排代码，以促进许多对象被添加和不被放置在同一位置的对象。

设置位置的代码是_ Set 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