代码之家 › 专栏 › 技术社区 › user23636411

Excel InputBox:使用唯一名称对形状和名称组进行分组

inputbox group shapes vba excel

user23636411 · 技术社区 · 1 周前

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

它使用2个输入框:

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

错误:如果用户选择了一个已经分组的范围,代码就会停止工作。错误:“运行时错误'438':对象不支持此属性或方法。”

如何在开头插入一个MsgBox,上面写着:“所选形状已分组。请更改您的选择。”并且仅在选择“有效”的情况下运行代码?

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

1 回复 | 直到 1 周前

taller 1 周前

ActiveSheet.Shapes.Range(..).Select 选择所需的形状
这个 If 以确定与所选范围相交的形状是否不可靠。例如,shape的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 ' no shape in selected range
      ReDim Preserve aShp(1 To iR)
    'Group Shapes and Name Group with unique name
      If iR > 1 Then ' more than one shapes
        ' ***
        ActiveSheet.Shapes.Range(aShp).Select ' select shapes
        Set grp = Selection.ShapeRange.Group  ' group shapes
        ' ***
        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