根据单元格值更改形状数量

Question

I have a macro that produces a scaled shape based on user inputted dimensions on the "enter information" sheet. The macro is linked to a button and once the button is clicked the shape appears on the user chosen sheet (ws - ws5) and the shape dimensions, quantity, and description are added to the "Vessel BOM" sheet. The user can input the quantity of shapes into a cell on the "enter information" sheet too, but so far I have been unable to link the shape quantity to produce more than one shape.

Right now I have another button (essentially the same macro but without adding the shape details to the "vessel BOM" sheet) the user can use to create additional shapes if the chosen quantity is more than one. I am attempting to eliminate that extra work.

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

Not sure exactly what you're asking, but you can create multiple shapes like so for example

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