CODEWITHSUNDEEP
excelvba
Pramod Pandit
Pramod Pandit

Reputation: 121

Multiple selection(Shapes) in VBA, Tip needed

I have 2 shapes(shp & shp1) with same property.I just wanted to know if there is a way to select both shapes(shp.select and shp1.select) so that i would not have to select twice and assign property twice.I tried worksheet.selectall but it results in error.I am just starter in these matter so i wanted to find a way to do it.

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

Upvotes: 1

Views: 1233

Answers (2)

FaneDuru
FaneDuru

Reputation: 42236

Try ws.Shapes.SelectAll in order to select all shapes on the sheet.

In order to select two specific shapes, you can use the next way:

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

In order to use your specific way (shp & shp1), you must name them after creation. shp.Name = "xx" and shp1.Name = "yy" and then use that in the next way:

 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!

Now, please use the next (your) adapted code able to do what (I understood) you need. It is commented in the relevant areas and I think it is easy to be uderstood. Do not forget to have a value in cell "A4"... The code firstly delete the existing shapes, if any. If you do not need that, you can comment those lines:

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

Upvotes: 1

VBasic2008
VBasic2008

Reputation: 54777

Looping Through the Shapes Collection

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

Applied to your code

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

Upvotes: 1

Related Questions