Excel 输入框：对形状进行分组并为具有唯一名称的组命名

Question

此代码允许用户对选定范围内的形状进行分组，并使用唯一的名称来命名该组。

它使用 2 个输入框：

• “1/2 选择形状范围”
• “2/2 输入群组名称”

错误：如果用户选择已经分组的范围，则代码将停止工作。错误：“运行时错误‘438’：对象不支持此属性或方法。”

如何在开头插入一个消息框：“所选形状已分组。请更改您的选择。”并使代码仅在选择“有效”时运行？

Option Explicit

'===============================================================================
' InputBox: Group Shapes and Name Group v4.0
'===============================================================================

Sub IPB_Group_Shapes_v4_0()

Dim ws As Worksheet

Dim shp As Shape
Dim rng As Range
Dim grp As Object

Set ws = ActiveSheet

'Application.ScreenUpdating = False
  On Error Resume Next
    Set rng = Application.InputBox(Title:="1/2 Select Shape Range", _
                                   Prompt:="", _
                                   Type:=8)
  On Error GoTo 0
  If Not rng Is Nothing Then
    'Hide any Shape Outside Selected Range
      For Each shp In ws.Shapes
        If Intersect(rng, shp.TopLeftCell) Is Nothing And _
          Intersect(rng, shp.BottomRightCell) Is Nothing Then
             If shp.Type <> msoComment Then shp.Visible = msoFalse
        End If
      Next shp
    'Select All Visible Shapes
      On Error GoTo Skip
        ws.Shapes.SelectAll
      On Error GoTo 0
    'Group Shapes and Name Group with unique name
      If VarType(Selection) = 9 Then
        Set grp = Selection.Group
        
        With grp
            Dim gName As String
            gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                         Default:="ClickGroup [00 Name] ", _
                                         Prompt:="", _
                                         Type:=2)
            If Not ValidateName(gName) Then
               MsgBox "Group name [" & gName & "] is duplicated." _
               & vbCrLf & "Try again.", vbExclamation, "Duplicate"
               gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                            Default:="ClickGroup [00 Name] ", _
                                            Prompt:="", _
                                            Type:=2)
            End If
            If ValidateName(gName) Then
                grp.Name = gName
            Else
                MsgBox "Group name [" & gName & "] is already taken." _
                & vbCrLf & "Please restart.", vbExclamation, "Restart"
                grp.Select
            End If
        End With

    MsgBox "Group Name:" & vbNewLine & vbNewLine & _
                 "" & grp.Name, , ""
  
        grp.Select
      End If

Skip:
    'Unhide rest of the Shapes
      For Each shp In ws.Shapes
        If shp.Type <> msoComment Then
          If shp.Visible = msoFalse Then shp.Visible = msoTrue
        End If
      Next shp
  End If

End Sub
'===============================================================================

想法：

If Selection Is grp Then
MsgBox "These Shapes are already grouped.", vbExclamation, "Please retry."
Else
End If

Answer 1

• ActiveSheet.Shapes.Range(..).Select

  选择所需的形状

• If

  判断形状与所选范围的交叉是否不可靠。例如。形状的 TopRightCell 可能在所选范围内。将代码更改为：

If Not Intersect(rng, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then

Option Explicit
'===============================================================================
' InputBox: Group Shapes and Name Group v4.0
'===============================================================================
Sub IPB_Group_Shapes_v4_0()
Dim ws As Worksheet
Dim shp As Shape
Dim rng As Range
Dim grp As Object
Dim aShp(), iR As Long
Set ws = ActiveSheet
'Application.ScreenUpdating = False
  On Error Resume Next
    Set rng = Application.InputBox(Title:="1/2 Select Shape Range", _
                                   Prompt:="", _
                                   Type:=8)
  On Error GoTo 0
  If Not rng Is Nothing Then
    ReDim aShp(1 To ws.Shapes.Count)
    'Hide any Shape Outside Selected Range
      For Each shp In ws.Shapes
        If Not Intersect(rng, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
            If shp.Type <> msoComment Then
                iR = iR + 1
                aShp(iR) = shp.Name
            End If
        End If
      Next shp
      If iR = 0 Then Exit Sub
      ReDim Preserve aShp(1 To iR)
    'Group Shapes and Name Group with unique name
      If iR > 1 Then
        ' ***
        ActiveSheet.Shapes.Range(aShp).Select
        Selection.ShapeRange.Group.Select
        Set grp = Selection
        ' ***
        With grp
            Dim gName As String
            gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                         Default:="ClickGroup [00 Name] ", _
                                         Prompt:="", _
                                         Type:=2)
            If Not ValidateName(gName) Then
               MsgBox "Group name [" & gName & "] is duplicated." _
               & vbCrLf & "Try again.", vbExclamation, "Duplicate"
               gName = Application.InputBox(Title:="2/2 Enter Group Name", _
                                            Default:="ClickGroup [00 Name] ", _
                                            Prompt:="", _
                                            Type:=2)
            End If
            If ValidateName(gName) Then
                grp.Name = gName
            Else
                MsgBox "Group name [" & gName & "] is already taken." _
                & vbCrLf & "Please restart.", vbExclamation, "Restart"
                grp.Select
            End If
        End With
    MsgBox "Group Name:" & vbNewLine & vbNewLine & _
                 "" & grp.Name, , ""
        grp.Select
      End If
Skip:
    'Unhide rest of the Shapes
    ' pass
  End If
End Sub
Function ValidateName(ByVal ShpName As String) As Boolean
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveSheet.Shapes(ShpName)
    On Error GoTo 0
    ValidateName = (s Is Nothing)
End Function