如何将形状添加到将在之前动态添加的新 sheet

Question

我正在编写代码来创建一个新的 sheet，其中包含用户定义的名称和代号。然后在 new sheet 的形状中垂直向下添加多个带有用户定义文本的形状。形状的数量将基于用户在第一个 sheet 中选择的单元格数量。当我尝试运行时，在新的 sheet 中添加形状的书面代码弹出“运行时间错误‘438’对象不支持此属性或方法”。我尝试运行使用现有的 sheet 使用相同的代码，运行没问题。有人可以帮助识别错误并提供解决方案吗？

PS：我不是编码员，所以外行语言解决方案会有帮助。附上代码，调试线是Set S = BN.Shapes.AddShape(msoShapeRectangle, 20, a, 200, 100)。现有 sheet 代号是“工具”，将添加的新 sheet 代号基于用变量 BN.

定义的用户输入

Sub Prepare_Bowtie()

Tool.Select
Cells(1, 1).Select
'Ask for Bowtie Number
Dim BN As Range
Set BN = Application.InputBox("Select Cell with Bowtie Number", "Bowtie preparation - Bowtie Number", Type:=8)

If BN = vbNullString Then
MsgBox "No Cell Selected"

Else
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = BN

With ActiveSheet
.Parent.VBProject.VBComponents(.CodeName).Properties("_CodeName") = BN
End With

Tool.Select

On Error GoTo 0
End If

Dim Threat As Variant
Threat = Application.InputBox("Select all cells with threats", "Bowtie preparation - Threat Selection", , , , , , 8)

Dim a As Long
Dim S As Shape
a = 20
For Each Threat In Selection

Set S = BN.Shapes.AddShape(msoShapeRectangle, 20, a, 200, 100)
S.Fill.ForeColor.RGB = RGB(0, 0, 0)

S.TextFrame.Characters.Text = Threat

With S.TextFrame.Characters.Font
.Color = RGB(255, 255, 255)
.Size = 15
.Name = "Calibri"
End With

With S.TextFrame
.Orientation = msoTextOrientationHorizontal
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With

a = a + 150
Next Threat

On Error Resume Next
Sheets(BN).Delete
On Error GoTo 0

End Sub

Answer 1

请测试下一个适配代码：

Sub Prepare_Bowtie()
 Dim Tool As Worksheet, BN As Range, newSh As Worksheet, Threat As Variant
 Dim rngTreat As Range, a As Long, S As Shape
 Set Tool = ActiveSheet
 Tool.Activate

Reselect:  'for the case of wrongly selected a cell containing an existing Bowtie Number
 'Ask for Bowtie Number
 Set BN = Application.InputBox("Select Cell with Bowtie Number (only one cell!)", "Bowtie preparation - Bowtie Number", Type:=8)

 If BN Is Nothing Then
    MsgBox "No Cell Selected": Exit Sub
 ElseIf BN.cells.count > 1 Then
    MsgBox "More then one cell Selected": Exit Sub
 ElseIf BN.Value = "" Then
   MsgBox "Empty cell Selected": Exit Sub
 End If

 If newSh Is Nothing Then 'in case of GoTo Reselect...
    Set newSh = Sheets.Add(After:=Sheets(Sheets.count)) 'set the added sheet
 End If
 With newSh
    On Error Resume Next
    .Name = BN
    If err.Number = 1004 Then
        err.Clear: On Error GoTo 0
        MsgBox "A sheet named """ & BN & """ already exists..." & vbCrLf & _
                   "Please, select another cell for the Boutie Number!": Tool.Activate: GoTo Reselect
    End If
    On Error GoTo 0
    .Parent.VBProject.VBComponents(.CodeName).Properties("_CodeName") = BN
 End With

 Tool.Activate
 Set rngTreat = Application.InputBox("Select all cells with threats", "Bowtie preparation - Threat Selection", , , , , , 8)

 a = 20
 For Each Threat In rngTreat
    Set S = newSh.Shapes.AddShape(msoShapeRectangle, 20, a, 200, 100)
    With S
        .Fill.ForeColor.RGB = RGB(0, 0, 0)
        .TextFrame.Characters.Text = Threat
    
        With .TextFrame.Characters.Font
            .color = RGB(255, 255, 255)
            .Size = 15
            .Name = "Calibri"
        End With
    
        With .TextFrame
            .Orientation = msoTextOrientationHorizontal
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
        End With
    End With
    a = a + 150
 Next Threat

 On Error Resume Next
   Sheets(BN).Delete 'this will never work! BN cannot be called in the same sub where it has been defined...
   'newSh.Delete      'if you want deleting it, uncomment this line
 On Error GoTo 0
End Sub

主要问题是 sheet CodeName 对代码方式的更改无法在更改后的 Sub 中使用。

那么，这个方法For Each Threat In Selection就起作用了，这样的选择是很有必要的。由于您的代码是通过选择“A1”单元格开始的，因此它仍然是选择。您必须了解，选择一个范围来创建 InputBox 一个，不会保留为选择。

我也先换了个方式InputBox查了一下。它是一个范围，无法根据 nullString 进行检查。请理解我用的是什么，理解起来并不复杂。

新的sheet命名方式略有改进，因为现有的sheet名称可能与尝试的名称相同。

如果有什么不清楚的地方，请随时要求澄清。

如何将形状添加到将在之前动态添加的新 sheet

How to add shapes to a new sheet which will be dynamically added before

excel

vba

worksheet

shapes