根據單元格值更改形狀數量

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