如何将现有VBA重命名形状代码批量应用到指定多列范围？

核心逻辑 #

遍历AZ:EU列的每一列，对应处理每列的两个单元格：

• 第30行：形状的新名称
• 第33行：形状的原名称

找到对应形状后重命名为新名称，同时将第33行的单元格值更新为新名称。

完整VBA代码 #

Sub BatchRenameShapes()
    Dim ws As Worksheet
    Dim col As Long
    Dim oldShapeName As String
    Dim newShapeName As String
    Dim targetShape As Shape
    
    ' 指定操作的工作表，按需修改表名
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 遍历AZ到EU列（自动识别列号，无需硬编码）
    For col = Columns("AZ").Column To Columns("EU").Column
        ' 获取当前列的原名称和新名称
        oldShapeName = ws.Cells(33, col).Value
        newShapeName = ws.Cells(30, col).Value
        
        ' 跳过空值，避免无效操作
        If oldShapeName = "" Or newShapeName = "" Then GoTo NextCol
        
        ' 查找目标形状，捕获找不到的情况
        On Error Resume Next
        Set targetShape = ws.Shapes(oldShapeName)
        On Error GoTo 0
        
        ' 找到形状则执行重命名和单元格更新
        If Not targetShape Is Nothing Then
            targetShape.Name = newShapeName
            ws.Cells(33, col).Value = newShapeName
        Else
            ' 控制台输出未找到的形状信息，方便排查
            Debug.Print "未找到形状：" & oldShapeName & "（列：" & ws.Cells(1, col).Address(False, False) & "）"
        End If
        
NextCol:
    Next col
    
    MsgBox "批量重命名完成！"
End Sub

关键说明 #

1. 工作表指定：修改ThisWorkbook.Worksheets("Sheet1")中的表名为你实际操作的工作表名称。
2. 循环范围：通过列号遍历AZ到EU列，无需手动计算列号，代码更易维护。
3. 空值过滤：跳过原名称或新名称为空的列，避免无意义的操作。
4. 错误处理：用On Error Resume Next处理找不到形状的场景，防止程序崩溃，同时输出日志便于排查问题。
5. 数据同步：重命名形状后立即更新第33行的单元格值，保证单元格记录与实际形状名称一致。

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