Excel VBA：实现形状命名InputBox的唯一性校验方案

需求说明：通过VBA代码向选定单元格区域添加2个椭圆形状，全程通过3个InputBox交互操作，核心要求是输入的形状名称必须唯一，若名称重复则弹出提示框显示This name is already taken。

方案一：自定义校验函数+1次重试机会 #

该方案通过自定义函数校验输入名称是否重复，用户有1次重试机会，若重试仍失败则需重新启动操作。

完整代码 #

Sub AddEllipses_Option1()
    Dim targetRange As Range
    Dim shp1 As Shape, shp2 As Shape
    Dim shpName1 As String, shpName2 As String
    Dim retryCount As Integer
    
    ' 选择目标单元格区域
    On Error Resume Next
    Set targetRange = Application.InputBox("Select target cell range", Type:=8)
    On Error GoTo 0
    If targetRange Is Nothing Then Exit Sub
    
    ' 获取第一个椭圆的名称（带1次重试）
    retryCount = 0
    Do
        shpName1 = InputBox("Enter name for first ellipse")
        If shpName1 = "" Then Exit Sub
        
        If IsShapeNameUnique(shpName1) Then
            Exit Do
        Else
            MsgBox "This name is already taken"
            retryCount = retryCount + 1
            If retryCount >= 1 Then
                MsgBox "Retry limit reached. Please restart the operation."
                Exit Sub
            End If
        End If
    Loop
    
    ' 获取第二个椭圆的名称（带1次重试）
    retryCount = 0
    Do
        shpName2 = InputBox("Enter name for second ellipse")
        If shpName2 = "" Then Exit Sub
        
        If IsShapeNameUnique(shpName2) Then
            Exit Do
        Else
            MsgBox "This name is already taken"
            retryCount = retryCount + 1
            If retryCount >= 1 Then
                MsgBox "Retry limit reached. Please restart the operation."
                Exit Sub
            End If
        End If
    Loop
    
    ' 添加第一个椭圆
    Set shp1 = targetRange.Worksheet.Shapes.AddShape(msoShapeOval, _
        targetRange.Left, targetRange.Top, targetRange.Width / 2, targetRange.Height)
    shp1.Name = shpName1
    
    ' 添加第二个椭圆
    Set shp2 = targetRange.Worksheet.Shapes.AddShape(msoShapeOval, _
        targetRange.Left + targetRange.Width / 2, targetRange.Top, targetRange.Width / 2, targetRange.Height)
    shp2.Name = shpName2
End Sub

' 自定义函数：校验形状名称是否唯一
Function IsShapeNameUnique(name As String) As Boolean
    Dim shp As Shape
    IsShapeNameUnique = True
    For Each shp In ActiveSheet.Shapes
        If shp.Name = name Then
            IsShapeNameUnique = False
            Exit Function
        End If
    Next shp
End Function

方案二：指定次数重试（存在shp2重试无限制问题） #

该方案支持用户对名称输入重试指定次数，但第二个椭圆（shp2）的重试逻辑存在无限制循环的问题，需注意修复。

完整代码 #

Sub AddEllipses_Option2()
    Dim targetRange As Range
    Dim shp1 As Shape, shp2 As Shape
    Dim shpName1 As String, shpName2 As String
    Dim maxRetries As Integer, retryCount As Integer
    
    maxRetries = 3 ' 设置最大重试次数
    
    ' 选择目标单元格区域
    On Error Resume Next
    Set targetRange = Application.InputBox("Select target cell range", Type:=8)
    On Error GoTo 0
    If targetRange Is Nothing Then Exit Sub
    
    ' 获取第一个椭圆的名称（指定重试次数）
    retryCount = 0
    Do
        shpName1 = InputBox("Enter name for first ellipse")
        If shpName1 = "" Then Exit Sub
        
        If IsShapeNameUnique(shpName1) Then
            Exit Do
        Else
            MsgBox "This name is already taken"
            retryCount = retryCount + 1
            If retryCount >= maxRetries Then
                MsgBox "Max retries reached. Operation aborted."
                Exit Sub
            End If
        End If
    Loop
    
    ' 获取第二个椭圆的名称（存在无限制重试问题）
    Do
        shpName2 = InputBox("Enter name for second ellipse")
        If shpName2 = "" Then Exit Sub
        
        If IsShapeNameUnique(shpName2) Then
            Exit Do
        Else
            MsgBox "This name is already taken"
            ' 此处未设置重试次数限制，会无限循环直到输入唯一名称
        End If
    Loop
    
    ' 添加第一个椭圆
    Set shp1 = targetRange.Worksheet.Shapes.AddShape(msoShapeOval, _
        targetRange.Left, targetRange.Top, targetRange.Width / 2, targetRange.Height)
    shp1.Name = shpName1
    
    ' 添加第二个椭圆
    Set shp2 = targetRange.Worksheet.Shapes.AddShape(msoShapeOval, _
        targetRange.Left + targetRange.Width / 2, targetRange.Top, targetRange.Width / 2, targetRange.Height)
    shp2.Name = shpName2
End Sub

' 自定义函数：校验形状名称是否唯一
Function IsShapeNameUnique(name As String) As Boolean
    Dim shp As Shape
    IsShapeNameUnique = True
    For Each shp In ActiveSheet.Shapes
        If shp.Name = name Then
            IsShapeNameUnique = False
            Exit Function
        End If
    Next shp
End Function

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