Question

最直接的目标是能够将两个形状组合成一个组合，它们可以一起拖动。我创建了两个形状，但是当代码运行时，形状仍未分组，我对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中的一个按钮，它会以注释所示的几种方式扩充这个方框（在旧方框中添加边框和一个方框）。我希望新创建的框与旧框合并或以某种方式折叠，因此很容易拖动。如果有另一种更简单的方法来选择这两个盒子，我很乐意听到输入。在选择的行或单元格列中找不到这两个框，并且可以在工作表中的任何位置，因此我无法应用范围。感谢您提供的任何帮助。如果需要任何其他澄清或我忘记了与问题相关的事情，请不要犹豫。提前全部感谢！

编辑：其余代码如下：

工作表代码：

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中？

1 个答案: