Множественный выбор (Shapes) в VBA, необходим совет

Question

У меня есть 2 фигуры (shp & shp1) с одинаковым свойством. Я просто хотел узнать, есть ли способ выбрать обе фигуры (shp.select и shp1.select), чтобы мне не пришлось выбирать дважды и назначать свойство дважды. Я пробовал worksheet.selectall, но это приводит к ошибке. Я только начинаю в этом вопросе, поэтому я хотел найти способ сделать это.

Private Sub RUN()
    Dim x As Long, cel As Range, ws As Worksheet, shp As Shape, y As Long, z As Long, orow As Long, ocol As Long, cel0 As Range, shp1 As Shape
    Set ws = ActiveSheet
    orow = 3
    ocol = 3
    y = ws.Range("A4").Value
    z = ws.Range("A5").Value
'number shapes
    Set cel = Range("E6")
    Set cel0 = cel.Offset(orow * (z - 1) + 4, 0)
    For x = 1 To y
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.Left, cel.Top, cel.Width, cel.Width)
        Set shp1 = ws.Shapes.AddShape(msoShapeOval, cel0.Left, cel0.Top, cel0.Width, cel0.Width)
        shp.Select
         With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
             .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        shp1.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            With .TextFrame
             .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
        Set cel = cel.Offset(0, ocol)
        Set cel0 = cel0.Offset(0, ocol)
        Next

Answer 1

Цикл по коллекции фигур

Option Explicit

' Write Shapes Names to the Immediate window (CTRL+G)
Sub ShapesNames()

    Dim ws As Worksheet
    Dim shp As Shape

    Set ws = Worksheets("Sheet1")

    For Each shp In ws.Shapes
        Debug.Print shp.Name
    Next shp

End Sub

' Now add the names you wish to an array (vntSh).
Sub ShapesChangeProperties()

    Dim ws As Worksheet
    Dim shp As Shape
    Dim vntSh As Variant

    Set ws = Worksheets("Sheet1")
    vntSh = Array(ws.Shapes("Oval 10"), ws.Shapes("Oval 16"))

    ' Use For Each to loop through the shapes.
    Dim vnt As Variant
    For Each vnt In vntSh
        Debug.Print vnt.Name
    Next vnt

    ' or:

    ' Use For Next to loop through the shapes.
    Dim i As Long
    For i = 0 To UBound(vntSh)
        Debug.Print vntSh(i).Name
    Next i

End Sub

Применимо к вашему коду

Sub ForEach()

    Dim vntSh As Variant
    Dim vnt As Variant
    vntSh = Array(shp, shp1)

    For Each vnt In vntSh
        With vnt
            .Fill.Visible = msoFalse
            With .TextFrame
                .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
    Next vnt

End Sub

' or:

Sub ForNext()

    Dim vntSh As Variant
    Dim i As Long
    vntSh = Array(shp, shp1)

    For i = 0 To UBound(vntSh)
        With vntSh(i)
            .Fill.Visible = msoFalse
            With .TextFrame
                .Characters.Text = x
                .Characters.Font.ColorIndex = 3
                .HorizontalAlignment = xlHAlignCenter
                .VerticalAlignment = xlVAlignCenter
            End With
            With .Line
                .Visible = msoTrue
                .ForeColor.RGB = RGB(255, 0, 0)
                .Transparency = 0
            End With
        End With
    Next i

End Sub

Answer 2

Попробуйте ws.Shapes.SelectAll, чтобы выбрать все фигуры на листе.

Чтобы выбрать две указанные c фигуры, вы можете использовать следующий способ:

 Dim sel As ShapeRange
  Set sel = ws.Shapes.Range(Array(ws.Shapes(1).Name, ws.Shapes(2).Name))
  sel.Select

Чтобы использовать ваш указанный c способ (shp & shp1), вы должны назвать их после создания. shp.Name = "xx" и shp1.Name = "yy", а затем используйте это следующим образом:

 Dim sel As ShapeRange
  Set sel = ws.Shapes.Range(Array("xx", "yy"))
   'or
  Set sel = ws.Shapes.Range(Array(shp.Name, shp1.Name))
   sel.Select
   'but they must have different names, in order to be individually identified!

Теперь, пожалуйста, используйте следующий (ваш) адаптированный код, способный делать то, что (я понял) вам нужно. Это комментируется в соответствующих областях, и я думаю, что это легко понять. Не забудьте указать значение в ячейке «А4» ... Код сначала удаляет существующие фигуры, если таковые имеются. Если вам это не нужно, вы можете прокомментировать эти строки:

Private Sub RUN()
    Dim x As Long, cel As Range, ws As Worksheet, shp As Shape, y As Long, z As Long
    Dim orow As Long, ocol As Long, cel0 As Range, shp1 As Shape
    Dim sel As ShapeRange, sh As Shape 'new declarations

    Set ws = ActiveSheet
    orow = 3: ocol = 3

    y = ws.Range("A4").value
    z = ws.Range("A5").value

    Set cel = Range("E6")
    Set cel0 = cel.Offset(orow * (z - 1) + 4, 0)

    'New: delete all existingn shapes, if any_______________
      ws.Shapes.SelectAll: Selection.Delete
    '_______________________________________________________

    'firstly create all shapes and write their TextFrame text:
    For x = 1 To y
        Set shp = ws.Shapes.AddShape(msoShapeOval, cel.left, cel.top, cel.width, cel.width)
          shp.TextFrame.Characters.text = x
        Set shp1 = ws.Shapes.AddShape(msoShapeOval, cel0.left, cel0.top, cel0.width, cel0.width)
          shp1.TextFrame.Characters.text = x

        Set cel = cel.Offset(0, ocol)
        Set cel0 = cel0.Offset(0, ocol)
    Next x
     'create the shaperange of all existing shapes___
     ws.Shapes.SelectAll
     Set sel = Selection.ShapeRange
     '_______________________________________________
    'Changge what can be done at once (except TextFrame properties)
    With sel
        .Fill.Visible = msoFalse
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(255, 0, 0)
            .Transparency = 0
        End With
    End With
    '____________________________________________________________

    'Change TextFrame properties (individually for each shape):
    For Each sh In sel
        With sh.TextFrame
            .Characters.Font.ColorIndex = 3
            .HorizontalAlignment = xlHAlignCenter
            .VerticalAlignment = xlVAlignCenter
        End With
    Next
    '__________________________________________________________
End Sub