为什么我无法将这两个形状分组到 vba excel 中？

Question

最直接的objective是能够将两个形状组合成一个组，以便将它们拖在一起。我已经创建了两个形状，但是当代码运行时，形状仍然没有分组我对 vba 比较陌生，所以我确定我使用了一些功能不正确。这是我试过的即时代码：

'Group the two boxes together
    Dim ShapeArray As Variant
    ShapeArray(0) = Box1.Name
    ShapeArray(1) = ActiveShape.Name

    ActiveSheet.Shapes.Range(ShapeArray(0, 1)).Group

上下文完整模块代码如下：

Sub Button2_Click()

    Dim ActiveShape As Shape
    Dim UserSelection As Variant

        'Pull-in what is selected on screen
    Set UserSelection = ActiveWindow.Selection

        'Determine if selection is a shape
    On Error GoTo NoShapeSelected
    Set ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
    On Error Resume Next

        'Do Something with your Shape variable
    With ActiveShape.line    'Add border
        .Weight = 5
        .ForeColor.RGB = RGB(21, 2, 191)
    End With
        'Create a Shape inside the shape
    Dim Box1 As Shape
    Dim tope

    tope = ActiveShape.TOP
    Set Box1 = Sheet1.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveShape.Left, tope, 10, 10)
    Box1.Fill.ForeColor.RGB = RGB(40, 30, 166)

    'Group the two boxes together
    Dim ShapeArray As Variant
    ShapeArray(0) = Box1.Name
    ShapeArray(1) = ActiveShape.Name

    ActiveSheet.Shapes.Range(ShapeArray(0, 1)).Group






    temp1 = ActiveShape.TextFrame.Characters.Caption

    If InStr(temp1, "In Prog") = 0 Then      ' Add Text
        selTxt = Split(temp1, Chr(10))
        shp.OLEFormat.Object.Caption = selTxt(0) & "             " & "In Prog"
                    For i = 1 To (UBound(selectText) - 1)
                        shp.OLEFormat.Object.Caption = selectText(i) & vbNewLine
                    Next i

    ActiveShape.TextFrame.Characters.Caption = ActiveShape.TextFrame.Characters.Caption & vbNewLine & "In Prog"
    End If




    'Error Handler
NoShapeSelected:
        MsgBox "You do not have a shape selected!"


End Sub

基本上，在突出显示一个框后，您可以按 excel 中的一个按钮，它会以几种方式扩充此框，如评论所示（在旧框内添加边框和一个框）。我希望新创建的框与旧框组合在一起或以某种方式折叠起来以便于拖动。如果有另一种更简单的方法来 select 这两个框，我很乐意听到输入。此外，这两个框在 select 单元格行或列中找不到，并且可以在工作表中的任何位置，因此我无法应用范围。感谢您提供的任何帮助。如果需要任何其他说明或者我忘记了与问题相关的内容，请随时询问。在此先感谢大家！

编辑：其余代码如下：

工作表代码：

Option Explicit
Public alltxt As String
Private selectText() As String

Private Sub CommandButton1_Click()
    UF1.Show
End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Target.Parent
    Dim temp
    Dim i

    Dim shp As Shape
    Dim line As Variant
    For Each shp In ws.Shapes   'loop through all shapes
        If shp.Type = msoShapeRectangle Then 'that are text boxes
            'write the header cells into the text box
            temp = shp.OLEFormat.Object.Caption
            'OLEFormat.Object.Caption
                If InStr(temp, "week") = 0 And InStr(temp, "In Prog") = 0 Then
                    shp.OLEFormat.Object.Caption = shp.OLEFormat.Object.Caption & vbNewLine & ws.Cells(4, shp.TopLeftCell.Column).Text & " - " & ws.Cells(4, shp.BottomRightCell.Column).Text
                ElseIf InStr(temp, "week") And InStr(temp, "In Prog") Then
                    selectText = Split(temp, Chr(10))
                    shp.OLEFormat.Object.Caption = ""
                    For i = 0 To (UBound(selectText) - 3)
                        shp.OLEFormat.Object.Caption = shp.OLEFormat.Object.Caption & selectText(i) & vbNewLine
                    Next i
                    shp.OLEFormat.Object.Caption = shp.OLEFormat.Object.Caption & vbNewLine & ws.Cells(4, shp.TopLeftCell.Column).Text & " - " & ws.Cells(4, shp.BottomRightCell.Column).Text & vbNewLine & "In Prog"
                ElseIf InStr(temp, "week") And InStr(temp, "In Prog") = 0 Then
                    selectText = Split(shp.OLEFormat.Object.Caption, Chr(10))
                    shp.OLEFormat.Object.Caption = ws.Cells(4, shp.TopLeftCell.Column).Text & " - " & ws.Cells(4, shp.BottomRightCell.Column).Text
                    For i = (UBound(selectText) - 1) To 0 Step -1
                        shp.OLEFormat.Object.Caption = selectText(i) & vbNewLine & shp.OLEFormat.Object.Caption
                    Next i
                End If

        End If
    Next shp
End Sub

用户表单代码：

Private Sub UserForm_Initialize()

'fill combobox catagory
Me.cmbCAT.AddItem "L1U"
Me.cmbCAT.AddItem "L1L"
Me.cmbCAT.AddItem "IN"
Me.cmbCAT.AddItem "SC"
Me.cmbCAT.AddItem "GE"
Me.cmbCAT.AddItem "TE"
Me.cmbCAT.AddItem "ExD"


'fill combobox resources
Me.cmbResource.AddItem "Item1"
Me.cmbResource.AddItem "Item2"

End Sub


Private Sub btnSubmit_Click()

Dim wrks As Worksheet
Set wrks = ThisWorkbook.Sheets("Sheet1")

Dim typ As String
typ = cmbCAT.Text

Dim Box As Shape
Set Box = Sheet1.Shapes.AddShape(msoShapeRectangle, 100, 100, 200, 60)
'AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 60)

If typ = "L1U" Then
    Box.Fill.ForeColor.RGB = RGB(255, 180, 18)
ElseIf typ = "L1L" Then
    Box.Fill.ForeColor.RGB = RGB(147, 196, 22)
ElseIf typ = "SC" Then
    Box.Fill.ForeColor.RGB = RGB(147, 196, 22)
ElseIf typ = "IN" Then
    Box.Fill.ForeColor.RGB = RGB(255, 255, 70)
ElseIf cmbCAT = "GE" Then
    Box.Fill.ForeColor.RGB = RGB(255, 173, 203)
ElseIf cmbCAT = "TE" Then
    Box.Fill.ForeColor.RGB = RGB(114, 163, 255)
Else
    Box.Fill.ForeColor.RGB = RGB(159, 2, 227)
End If

Box.TextFrame.Characters.Caption = tbSP & "-" & tbDROP & "." & cmbCAT & "." & tbUS & vbNewLine & _
"Resource: " & cmbResource & vbNewLine & _
"Description: " & tbDES & vbNewLine



Unload UF1

End Sub

Answer 1

试试下面的，一般的syntax就是Range(Array("shape1", "shape2")).Group

 Dim ShapeArray(0 To 1) As String
 ShapeArray(0) = Box1.Name
 ShapeArray(1) = ActiveShape.Name

 ActiveSheet.Shapes.Range(Array(ShapeArray(0), ShapeArray(1))).Group

为什么我无法将这两个形状分组到 vba excel 中？

Why am i not able to group these two shapes in vba excel?

excel

vba

shape

shapes