基于细胞价值改变形状数量

Question

我有一个宏，根据“输入信息”表上的用户输入尺寸产生缩放形状。宏链接到一个按钮，单击该按钮后，形状将显示在用户选择的工作表（ws - ws5）上，形状尺寸，数量和描述将添加到“容器BOM”工作表中。用户也可以在“输入信息”表单上将形状数量输入到单元格中，但到目前为止，我无法链接形状数量以生成多个形状。

现在我有另一个按钮（基本上是相同的宏，但没有将形状细节添加到“容器BOM”表），如果所选数量多于一个，用户可以使用它来创建其他形状。我试图消除那些额外的工作。

Sub AddShapeToCell()

Dim s As Shape
Dim r As Long
Dim ws As Worksheet
Set ws = Sheets("Deep Blue")
Set ws1 = Sheets("GC II")
Set ws2 = Sheets("300ft Barge")
Set ws3 = Sheets("275ft Barge")
Set ws4 = Sheets("250ft Barge")
Set ws5 = Sheets("User Defined Vessel")
Dim TriggerCellb As Range
Set TriggerCellb = Range("D8")
Const scaling As Double = 2.142857


'Create a shape

If TriggerCellb.Value = "Deep Blue" Then
Set s = ws.Shapes.AddShape(Cells(4, 17), 53, 66, Cells(20, 4) * scaling * 
Cells(5, 17), Cells(22, 4) * scaling * Cells(5, 17))

ElseIf TriggerCellb.Value = "GC II" Then
Set s = ws1.Shapes.AddShape(Cells(4, 17), 53, 66, Cells(20, 4) * scaling * 
Cells(5, 17), Cells(22, 4) * scaling * Cells(5, 17))

ElseIf TriggerCellb.Value = "300ft Barge" Then
Set s = ws2.Shapes.AddShape(Cells(4, 17), 53, 66, Cells(20, 4) * scaling * 
Cells(5, 17), Cells(22, 4) * scaling * Cells(5, 17))

ElseIf TriggerCellb.Value = "275ft Barge" Then
Set s = ws3.Shapes.AddShape(Cells(4, 17), 53, 66, Cells(20, 4) * scaling * 
Cells(5, 17), Cells(22, 4) * scaling * Cells(5, 17))

ElseIf TriggerCellb.Value = "250ft Barge" Then
Set s = ws4.Shapes.AddShape(Cells(4, 17), 53, 66, Cells(20, 4) * scaling * 
Cells(5, 17), Cells(22, 4) * scaling * Cells(5, 17))

ElseIf TriggerCellb.Value = "User Defined Vessel" Then
Set s = ws5.Shapes.AddShape(Cells(4, 17), 53, 66, Cells(20, 4) * scaling * 
Cells(5, 17), Cells(22, 4) * scaling * Cells(5, 17))

End If
'make it nearly white
s.Fill.ForeColor.RGB = RGB(245, 245, 255)

'show text within it
s.TextFrame.Characters.Text = Range("d12").Value
s.TextFrame.Characters.Font.ColorIndex = 2

With s.TextFrame.Characters(0, 0)
s.TextFrame.HorizontalAlignment = xlHAlignCenter
s.TextFrame.VerticalAlignment = xlVAlignCenter
.Font.Color = RGB(0, 0, 0)

End With

'add to BOM
Dim lastCell As Range
Set lastCell = Sheets("Vessel BOM").Range("C" & 
Rows.Count).End(xlUp).Offset(1, 0)

Sheets("Enter Information").Range("g20:m20").Copy
lastCell.PasteSpecial (xlPasteValues)

Sheets("Enter Information").Range("g20:m20").Copy
lastCell.PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False

End Sub

Answer 1

不确定你究竟在问什么，但你可以创建多个形状，例如

Sub x()

Dim s As Shape, i As Long

For i = 1 To range("A1").value
    Set s = ActiveSheet.Shapes.AddShape(msoShapeBevel, 10, 20 * i, 10, 10)
Next i

End Sub