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

Question

我有一个宏可以根据用户在 "enter information" sheet 上输入的尺寸生成缩放形状。宏被 link 编辑到一个按钮，单击按钮后，形状出现在用户选择的 sheet (ws - ws5) 上，形状尺寸、数量和描述被添加到 "Vessel BOM" sheet。用户也可以在 "enter information" sheet 上的单元格中输入形状的数量，但到目前为止我无法 link 形状数量来生成多个形状。

现在我有另一个按钮（本质上是相同的宏，但没有向 "vessel BOM" sheet 添加形状细节）如果选择的数量超过，用户可以使用它来创建其他形状一。我正试图消除这些额外的工作。

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

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

Changing Shape Quantity Based On Cell Value

excel

vba

shapes