Excel VBA通配符查找形状报错 求矩形编号递增实现方案

问题分析 #

你遇到的Object doesn't support this property or method错误，核心原因是直接对Shape对象使用Like运算符——shp是一个Shape对象实例，不能直接和字符串做匹配，你需要访问它的Name属性来判断名称是否符合规则。另外你的代码里还有几处小问题（比如未定义的Number变量），我一起帮你修正。

关键修改点 #

• 形状名称匹配：把If shp Like "Rectangle" Then改成If shp.Name Like "Rectangle*" Then，用*通配符匹配所有以"Rectangle"开头的形状（应对复制后名称变成Rectangle 2、Rectangle 3的情况）
• 修复未定义变量：代码里的Number应该是你定义的xNumber，否则会触发变量未定义错误
• 矩形文本递增逻辑：新工作表的矩形数字应该和工作表序号一致，直接用i + 1或者新工作表B60的值（你已经给B60赋值为i + 1）
• 规范语法：VBA里的Offset首字母要大写，避免潜在的语法问题

修正后的完整代码 #

Sub otdr()
    Dim i As Long, j As Long, Lastrow As Long
    Dim xNumber As Long, yNumber As Long
    Dim otdr As Range, desc As Range, fet As Range, boxdesc As Range
    Dim xName As String
    Dim ws As Worksheet, wk As Worksheet
    Dim shp As Shape
    Application.ScreenUpdating = False
    
    Set ws = Sheets("OTDR TRACE - 1")
    Set wk = Sheets("Fibre drop release sheet")
    Set fet = wk.Range("E3")
    Set otdr = ws.Range("Q46")
    Set desc = ws.Range("B52")
    Set boxdesc = ws.Range("B60")
    
    xNumber = Sheets("Frontsheet").Range("D32").Value
    Lastrow = wk.Cells(wk.Rows.Count, "E").End(xlUp).Row
    
    ' 循环创建新工作表
    For i = 1 To (xNumber - 1)
        ' 更新原工作表的OTDR标识
        otdr = "OT " & (i + 1) & " of " & xNumber
        ' 更新描述
        desc = fet.Offset(1, 1)
        ' 复制工作表
        ws.Copy After:=ActiveWorkbook.Sheets(ws.Index + i - 1)
        With ActiveSheet
            ' 设置B60的值为递增序号
            .Range("B60").Value = i + 1
            ' 重命名工作表
            .Name = "OTDR TRACE - " & i + 1
            ' 遍历所有形状，找到矩形并更新文本
            For Each shp In .Shapes
                ' 匹配所有以Rectangle开头的形状
                If shp.Name Like "Rectangle*" Then
                    shp.TextFrame2.TextRange.Characters.Text = .Range("B60").Value
                End If
            Next shp
        End With
    Next i
    
    ' 还原原工作表的OTDR标识
    ws.Activate
    otdr = "OT 1 of " & xNumber
    
    Application.ScreenUpdating = True
End Sub

额外说明 #

• 用With ActiveSheet来简化代码，减少重复调用ActiveSheet，提升运行效率
• 矩形文本直接取新工作表B60的值，确保和你设置的序号完全一致，避免逻辑不一致
• 匹配Rectangle*可以覆盖所有复制后自动重命名的矩形（比如Rectangle 2、Rectangle 3...），不会遗漏

内容的提问来源于stack exchange，提问作者Geographos