I have six objects, all in a given fixed position, as depicted below
The text boxes all have the same size. I would like to automate the counterclockwise rotation of all text boxes, so that when I use the macro, it will rotate the text 60º ccw (thus BETA becomes ALPHA, ALPHA becomes ZETA and so forth). However, I'm completely clueless on how to write it in VBA! I know that I can set the textbox using
Set myDocument = ActivePresentation.Slides(1)
myDocument.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, _
Left:=400, Top:=100, Width:=160, Height:=30).TextFrame _
.TextRange.Text = "ALPHA"
But, I'm clueless on how to rotate them. Another alternative would be to create these six TextBoxes and create a function that only changed the text variable, but my VBA knowledge is very elementary, and I wouldn't even know where to begin :\
Can anyone be so kind as to give me a small help?
If you mean to rotate their position and not their orientation it could look like this:
Option Explicit
Public Sub ExampleRotatePositions()
Dim myDocument As Slide
Set myDocument = ActivePresentation.Slides(1)
Dim TextBox(1 To 6) As Shape
'create the textboxes in your desired position.
Set TextBox(1) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=100, Top:=100, Width:=160, Height:=30)
TextBox(1).TextFrame.TextRange.Text = "ALPHA"
Set TextBox(2) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=200, Top:=100, Width:=160, Height:=30)
TextBox(2).TextFrame.TextRange.Text = "BETA"
Set TextBox(3) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=300, Top:=100, Width:=160, Height:=30)
TextBox(3).TextFrame.TextRange.Text = "GAMMA"
Set TextBox(4) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=400, Top:=100, Width:=160, Height:=30)
TextBox(4).TextFrame.TextRange.Text = "DELTA"
Set TextBox(5) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=500, Top:=100, Width:=160, Height:=30)
TextBox(5).TextFrame.TextRange.Text = "EPSILON"
Set TextBox(6) = myDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=600, Top:=100, Width:=160, Height:=30)
TextBox(6).TextFrame.TextRange.Text = "ZETA"
MsgBox "Start rotating now"
'remember last position
Dim LastLeft As Single
LastLeft = TextBox(UBound(TextBox)).Left
Dim LastTop As Single
LastTop = TextBox(UBound(TextBox)).Top
'rotate position
Dim iTextBox As Long
For iTextBox = UBound(TextBox) - 1 To LBound(TextBox) Step -1
TextBox(iTextBox + 1).Left = TextBox(iTextBox).Left
TextBox(iTextBox + 1).Top = TextBox(iTextBox).Top
Next iTextBox
'move first to last position
TextBox(LBound(TextBox)).Left = LastLeft
TextBox(LBound(TextBox)).Top = LastTop
End Sub
Group them using the ShapeRange.Group method and then rotate the group:
Set myDocument = ActivePresentation.Slides(1)
With myDocument.Shapes
.AddShape(msoShapeCan, 50, 10, 100, 200).Name = "shpOne"
.AddShape(msoShapeCube, 150, 250, 100, 200).Name = "shpTwo"
With .Range(Array("shpOne", "shpTwo")).Group
.Fill.PresetTextured msoTextureBlueTissuePaper
.Rotation = 45
.ZOrder msoSendToBack
End With
End With
Related
I'm generating a largish presentation to run during a game showing players what stages they should have reached (the game isn't important). Each slide has a hollow circle/donut sweeping out an overall time while pictures appear showing the stage players should have reached. (The slides are being macro-generated as there are many variations, differing only slightly, including in timing details.)
When there are no sound effects, the macro works perfectly. When a sound effect is added to any .effect, the entire animation sequence is changed significantly and incorrectly. Timings that are assigned to start "With Previous" become "After Previous", durations are changed, the fade effect is lost. I've tried changing the sequence of the effect attribute assignments, adding a dummy shape and assigning the sound to that, no success.
Copying and running this simplified version demonstrates what happens - the same sub is used to generate two single-slide presentations on the desktop which should be the same other than sound effects, but are not.
Const CycleTime = 10
' CycleTime = Seconds for which the circular sweep should run;
' A shape appears for the first half then fades to be replaced by a second shape.
Dim fn$
Public Sub MakeTestPresentations()
fn$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "Test#" & Format(Now(), "hhmmss")
Call MakeASlide(UsingSound:=False)
Call MakeASlide(UsingSound:=True)
Exit Sub
End Sub
Sub MakeASlide(ByVal UsingSound As Boolean)
Dim sldThis As Slide, swp As Shape, shp1 As Shape, shp2 As Shape
' New blank presentation
Set pptSource = Presentations.Add
' Add a blank slide
Set sldThis = pptSource.Slides.Add(Index:=1, Layout:=ppLayoutBlank)
' Add a donut which will be the overall timer, set to sweep in CycleTime seconds
Set swp = sldThis.Shapes.AddShape(msoShapeDonut, 525, 83, 369, 369)
swp.Fill.ForeColor.RGB = RGB(0, 0, 128)
sldThis.TimeLine.MainSequence.AddEffect(Shape:=swp, effectId:=msoAnimEffectWheel, Trigger:=msoAnimTriggerWithPrevious).Timing.Duration = CycleTime
' Add a shape which should appear for the first half of the cycle, fading in & out
Set shp1 = sldThis.Shapes.AddShape(msoShapeCloud, 83, 83, 369, 369)
shp1.Fill.ForeColor.RGB = RGB(0, 255, 0)
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp1, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = 0
.Timing.Duration = CycleTime / 2
If UsingSound Then .EffectInformation.SoundEffect.Name = "Laser"
End With
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp1, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime / 2
.Exit = True
End With
' Add a shape which should appear for the second half of the cycle, fading in & out
Set shp2 = sldThis.Shapes.AddShape(msoShape16pointStar, 83, 83, 369, 369)
shp2.Fill.ForeColor.RGB = RGB(255, 0, 0)
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp2, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime / 2
.Timing.Duration = CycleTime / 2
If UsingSound Then .EffectInformation.SoundEffect.Name = "Drum Roll"
End With
With sldThis.TimeLine.MainSequence.AddEffect(Shape:=shp2, effectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerWithPrevious)
.Timing.TriggerDelayTime = CycleTime
.Exit = True
End With
' Save the presentation
pptSource.SaveCopyAs fn$ & IIf(UsingSound, " (WITH Sound)", " (NO Sound)"), ppSaveAsDefault
pptSource.Close
Exit Sub
End Sub
I have a simple sub for adding background music:
Sub insert_rnd_back(Track As String)
Dim oSlide As Slide
Dim oShp As Shape
Dim oEffect As Effect
Set oSlide = ActivePresentation.Slides(1)
Set oShp = oSlide.Shapes.AddMediaObject2(Track, True, False, 10, 610)
With oShp.AnimationSettings.PlaySettings
.PlayOnEntry = msoTrue
.PauseAnimation = msoFalse
.StopAfterSlides = ActivePresentation.Slides.Count
.LoopUntilStopped = msoTrue
.HideWhileNotPlaying = msoTrue
.RewindMovie = msoTrue
End With
oShp.MediaFormat.Volume = 0.5
End Sub
And I am adding sounds to individual shapes with this:
Dim oShp As Shape
Dim oEffect As Effect
Set oShp = ActivePresentation.Slides(sld).Shapes.AddMediaObject2( _
aud & sityvebi(sld) & ".wav", True, False, 100, 610)
Set oEffect = ActivePresentation.Slides(sld).TimeLine.MainSequence.AddEffect( _
oShp, msoAnimEffectMediaPlay, , msoAnimTriggerAfterPrevious)
oShp.MediaFormat.Volume = 1
I want to give glow/shrink animation to a text in PowerPoint using VBA.
I can not configure it to give size 110% (it takes default size 150%) & also want a smooth end to 2 sec.
I tried the scale property but did not get my result.
Set osld = ActivePresentation.Slides(1)
Set dshp = osld.Shapes("LeftText")
osld.TimeLine.MainSequence.AddEffect dshp, msoAnimEffectGrowShrink, , msoAnimTriggerWithPrevious
For C = 1 To osld.TimeLine.MainSequence.Count
Set oeff = osld.TimeLine.MainSequence(C)
oeff.Timing.TriggerType = msoAnimTriggerWithPrevious
oeff.Timing.TriggerDelayTime = 2
'oeff.Behaviors.Add(msoAnimTypeScale).ScaleEffect.ByY = 110
'oeff.Behaviors.Add(msoAnimTypeScale).ScaleEffect.ByX = 110
Next C
Give this a try:
Sub GlowAnimationOptions()
Dim effGrowShrink As Effect
Set osld = ActivePresentation.Slides(1)
Set dshp = osld.Shapes("LeftText")
Set effGrowShrink = osld.TimeLine.MainSequence.AddEffect(Shape:=dshp, EffectID:=msoAnimEffectGrowShrink, Trigger:=msoAnimTriggerWithPrevious)
With effGrowShrink
With .EffectParameters
.Size = 120
End With
With .Timing
.SmoothEnd = msoTrue
.Duration = 4
End With
End With
End Sub
I would like to align ( in this case center)a shape( round cornered rectangle) within sharp cornered rectangle in a slide i.e the center point of both shapes should be equal using VBA without using 'Selection'.I am thinking to reference them via names(Like, wherever these two shapes come as a bunch, macro should align them) but not sure how to start.
Excuse me for the layman's explanation. Any thoughts would really be helpful and push me to start.
You'll have to set up a loop to check each shape in the slide, finding if its Type is an AutoShape, then if its AutoShapeType is msoShapeRoundedRectangle or msoShapeRectangle. As each are found, you would store the name of each in a variable. If both are found then you would get the left, top, width and height measurements for each and set those values so the centers align.
Sub CenterShapes()
Dim oSlide As Slide
Dim oShape As Shape
Dim bFoundRRect As Boolean, bFoundRect As Boolean
Dim RRectName$, RectName$
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoAutoShape Then
If oShape.AutoShapeType = msoShapeRoundedRectangle Then
bFoundRRect = True
RRectName$ = oShape.Name
End If
If oShape.AutoShapeType = msoShapeRectangle Then
bFoundRect = True
RectName$ = oShape.Name
End If
End If
Next oShape
If bFoundRRect = True And bFoundRect = True Then
RRectVCenter = oSlide.Shapes(RRectName$).Top + (oSlide.Shapes(RRectName$).Height / 2)
RRectHCenter = oSlide.Shapes(RRectName$).Left + (oSlide.Shapes(RRectName$).Width / 2)
RectVCenter = oSlide.Shapes(RectName$).Top + (oSlide.Shapes(RectName$).Height / 2)
RectHCenter = oSlide.Shapes(RectName$).Left + (oSlide.Shapes(RectName$).Width / 2)
VDif = RRectVCenter - RectVCenter
HDif = RRectHCenter - RectHCenter
oSlide.Shapes(RectName$).Top = oSlide.Shapes(RectName$).Top + VDif
oSlide.Shapes(RectName$).Left = oSlide.Shapes(RectName$).Left + HDif
End If
Next oSlide
End Sub
This example assumes you know, or determine with your code, the names of the shapes you want to align. Then it's a quick manner of setting up a ShapeRange and using the built-in alignment functions in PowerPoint.
Option Explicit
Sub AlignMe()
Dim theseShapeNames As Variant
theseShapeNames = Array("Rectangle 3", "Rectangle 4", "Rectangle 5")
Dim thisSlide As Slide
Dim theseShapes As ShapeRange
Set thisSlide = ActivePresentation.Slides(1)
Set theseShapes = thisSlide.Shapes.Range(theseShapeNames)
theseShapes.Align msoAlignCenters, msoFalse
End Sub
I'm trying to make text in the data label of the chart with shadow effect (that shadow effect which you have at top of the PowerPoint menu), but I'm unable to make it work, dataLabels.shadow or dataLabels.font.shadow makes the frame shadowed, not the text.
I was googling a lot, I have found out this could be possible via TextFormat or TextFormat2 property, unfortunately I'm not able to access it for the text in the data label anyhow. My current code, lines after comment does not work:
For Each Shape In Slide.Shapes
If Shape.HasChart Then
Dim i As Integer
Dim v As Variant
Set pts = Shape.Chart.SeriesCollection(1).Points
For Each s In Shape.Chart.SeriesCollection
v = s.Values
If s.Name <> "XXX_XXX" Then
If v(pts.Count) >= 0.05 Then
s.Select
s.Points(pts.Count).Select
s.Points(pts.Count).ApplyDataLabels
s.DataLabels.Font.Color = s.Border.Color
s.DataLabels.Font.Size = 20
s.DataLabels.Font.Name = "Calibri"
's.DataLabels.Shadow = True
's.DataLabels.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel.Font.Shadow = msoTrue
's.Points(pts.Count).DataLabel(pts.Count).TextFrame.TextRange.Font.Shadow = msoTrue
End If
End If
Next s
End If
Next Shape
If someone will have problems with simillar case I have found the answer :)
The shadow (ribbon like shadow) for data label text/value is done via TextRange2 property, but I was missing Format. Like this :
Dim tr As TextRange2
Set tr = s.DataLabels(pts.Count).Format.TextFrame2.TextRange
With tr.Font.Shadow
.OffsetX = 10
.OffsetY = 10
.Size = 1
.Blur = 4
.Transparency = 0.5
.Visible = True
End With
In Excel vba, I am creating two shapes in excel using vba. An arrow, which I name "aro" + i, and a textbox, which I name "text" + i, where i is a number indicating the number of a photograph.
So, say for photograph 3 I will creat arrow "aro3" and textbox "text3".
I then want to group them and rename that group "arotext" + i, so "arotext3" in this instance.
So far I have been doing the grouping and renaming like this:
targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name)).Select
Selection.group
Selection.Name = "AroTxt" & Number
which works splendidly in a sub, but now I want to change this into a function and return the named group, so I tried something like this:
Dim arrowBoxGroup as Object
set arrowBoxGroup = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
arrowBoxGroup.group
arrowBoxGroup.Name = "AroTxt" & Number
I run into problems when I create a new group which has the same name as one which has already been created. So, if I create a second "aro3" and "text3" and then try to group them and rename the group to "arotext3" I get an error because a group with the same name is already present.
The thing I don't understand is that when I did this using the method referring to the selection, I could rename every group with the same name if I wanted and wouldn't get an error. Why does it work when referring to the Selection object, but fails when trying to use an assigned object?
UPDATE:
Since somebody asked, the code I have so far is below. arrow and textbox are an arrow and a textbox which point into a direction arbitrarily defined by the user using a form.
This then creates an arrow at the correct angle on the target worksheet and places a textbox with the specified number (also through the form) at the end of the arrow, so that it effectively forms a callout. I know that there are callouts, but they don't do what I want so I had to make my own.
I have to group the textbox and arrow because 1) they belong together, 2) I keep track of which callouts have already been placed using the group's name as a reference, 3) the user has to place the callout in the right location on a map which is embedded in the worksheet.
So far I have managed to make this into a function by making the return value a GroupObject. But this still relies on Sheet.Shapes.range().Select, which in my opinion is a very bad way of doing this. I am looking for a way which does not rely on the selection object.
And I would like to understand why this works when using selection, but fails when using strong typed variables to hold the objects.
Public Function MakeArrow(ByVal No As Integer, ByVal angle As Double, ByVal size As ArrowSize, ByVal ArrowX As Double, ByVal ArrowY As Double, ByVal TargetInternalAngle As Double, ByRef targetSheet As Worksheet) As GroupObject
Dim Number As String
Dim fontSize As Integer
Dim textboxwidth As Integer
Dim textboxheight As Integer
Dim arrowScale As Double
Dim X1 As Double
Dim Y1 As Double
Dim X2 As Double
Dim Y2 As Double
Dim xBox As Double
Dim yBox As Double
Dim testRange As Range
Dim arrow As Shape
Dim textBox As Shape
' Dim arrowTextbox As ShapeRange
' Dim arrowTextboxGroup As Variant
Select Case size
Case ArrowSize.normal
fontSize = fontSizeNormal
arrowScale = arrowScaleNormal
Case ArrowSize.small
fontSize = fontSizeSmall
arrowScale = arrowScaleSmall
Case ArrowSize.smaller
fontSize = fontSizeSmaller
arrowScale = arrowScaleSmaller
End Select
arrowScale = baseArrowLength * arrowScale
'Estimate required text box width
Number = Trim(CStr(No))
Set testRange = shtTextWidth.Range("A1")
testRange.value = Number
testRange.Font.Name = "ＭＳ Ｐ明朝"
testRange.Font.size = fontSize
shtTextWidth.Columns(testRange.Column).EntireColumn.AutoFit
shtTextWidth.Columns(testRange.row).EntireRow.AutoFit
textboxwidth = testRange.Width * 0.8
textboxheight = testRange.Height * 0.9
testRange.Clear
'Make arrow
X1 = ArrowX
Y1 = ArrowY
X2 = X1 + arrowScale * Cos(angle)
Y2 = Y1 - arrowScale * Sin(angle)
Set arrow = AddArrow(X1, Y1, X2, Y2, Number, targetSheet)
'Make text box
Set textBox = Addtextbox(angle, Number, fontSize, X2, Y2, textboxwidth, textboxheight, TargetInternalAngle, targetSheet)
'Group arrow and test box
targetSheet.shapes.Range(Array(arrow.Name, textBox.Name)).group.Select
Selection.Name = "AroTxt" & Number
Set MakeArrow = Selection
' Set arrowTextbox = targetSheet.shapes.Range(Array(arrow.Name, textBox.Name))
' Set arrowTextboxGroup = arrowTextbox.group
' arrowTextboxGroup.Name = "AroTxt" & Number
'
' Set MakeArrow = arrowTextboxGroup
End Function
Private Function AddArrow(ByVal StartX As Double, ByVal StartY As Double, ByVal EndX As Double, ByVal EndY As Double, ByVal Number As String, ByRef targetSheet As Worksheet) As Shape
Set AddArrow = targetSheet.shapes.AddLine(StartX, StartY, EndX, EndY)
With AddArrow
.Name = "Aro" & Number
With .Line
.BeginArrowheadStyle = msoArrowheadTriangle
.BeginArrowheadLength = msoArrowheadLengthMedium
.BeginArrowheadWidth = msoArrowheadWidthMedium
.ForeColor.RGB = RGB(0, 0, 255)
End With
End With
End Function
Private Function Addtextbox(ByVal angle As Double, ByVal Number As String, ByVal fontSize As Integer, ByVal arrowEndX As Double, ByVal arrowEndY As Double, ByVal Width As Integer, ByVal Height As Integer, ByVal LimitAngle As Double, ByRef targetSheet As Worksheet) As Shape
Dim xBox, yBox As Integer
Dim PI As Double
Dim horizontalAlignment As eTextBoxHorizontalAlignment
Dim verticalAlignment As eTextBoxVerticalAlignment
PI = 4 * Atn(1)
If LimitAngle = 0 Then
LimitAngle = PI / 4
End If
Select Case angle
'Right
Case 0 To LimitAngle, 2 * PI - LimitAngle To 2 * PI
xBox = arrowEndX
yBox = arrowEndY - Height / 2
horizontalAlignment = eTextBoxHorizontalAlignment.left
verticalAlignment = eTextBoxVerticalAlignment.Center
'Top
Case LimitAngle To PI - LimitAngle
xBox = arrowEndX - Width / 2
yBox = arrowEndY - Height
horizontalAlignment = eTextBoxHorizontalAlignment.Middle
verticalAlignment = eTextBoxVerticalAlignment.Bottom
'Left
Case PI - LimitAngle To PI + LimitAngle
xBox = arrowEndX - Width
yBox = arrowEndY - Height / 2
horizontalAlignment = eTextBoxHorizontalAlignment.Right
verticalAlignment = eTextBoxVerticalAlignment.Center
'Bottom
Case PI + LimitAngle To 2 * PI - LimitAngle
xBox = arrowEndX - Width / 2
yBox = arrowEndY
horizontalAlignment = eTextBoxHorizontalAlignment.Middle
verticalAlignment = eTextBoxVerticalAlignment.top
End Select
Set Addtextbox = targetSheet.shapes.Addtextbox(msoTextOrientationHorizontal, xBox, yBox, Width, Height)
With Addtextbox
.Name = "Txt" & Number
With .TextFrame
.AutoMargins = False
.AutoSize = False
.MarginLeft = 0#
.MarginRight = 0#
.MarginTop = 0#
.MarginBottom = 0#
Select Case verticalAlignment
Case eTextBoxVerticalAlignment.Bottom
.verticalAlignment = xlVAlignBottom
Case eTextBoxVerticalAlignment.Center
.verticalAlignment = xlVAlignCenter
Case eTextBoxVerticalAlignment.top
.verticalAlignment = xlVAlignTop
End Select
Select Case horizontalAlignment
Case eTextBoxHorizontalAlignment.left
.horizontalAlignment = xlHAlignLeft
Case eTextBoxHorizontalAlignment.Middle
.horizontalAlignment = xlHAlignCenter
Case eTextBoxHorizontalAlignment.Right
.horizontalAlignment = xlHAlignRight
End Select
With .Characters
.Text = Number
With .Font
.Name = "ＭＳ Ｐ明朝"
.FontStyle = "標準"
.size = fontSize
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
End With
.Fill.Visible = msoFalse
.Fill.Solid
.Fill.Transparency = 1#
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.style = msoLineSingle
.Transparency = 0#
.Visible = msoFalse
End With
End With
End Function
Range.Group returns a value. You might try:
Set arrowBoxRange = targetSheet.shapes.Range(Array(Arrow.Name, textBox.Name))
Set arrowBoxGroup = arrowBoxRange.Group
arrowBoxGroup.Name = "AroTxt" & Number
I suspect that the current Selection gets updated as if the following in your earlier work:
Set Selection = Selection.Group 'it's as if this is done for you when you create the group.
which is causing the difference.
FYI, I'm using Excel 2010 and cannot duplicate the original code snippet based on Selection (I get an error doing "Selection.Name = ", which gives object does not support property.)
Ok, I can get this to work:
Selection.Group.Select
Selection.Name = "AroTxt"
Of course, like the other snippet I suggest, this reassigns the group's return value, so that Selection in Selection.Group and Selection.Name are referring to different objects, which I think is what you want.
It is because you are storing the new groups as an object manually now that this error has appeared. You probably are not able to do anything with the multiple instances of "AroTxt" & Number that you have created. As excel wouldn't be able to decide which group you mean.
Excel shouldn't allow this but it doesn't always warn that this has happened but will error if you try to select a group that has a duplicate name.
Even if this isn't the case, it isn't good practice to have duplicate variable names. Would it not be better to add the extra Arrow's and textBox's to the group?
So to solve your problem you will have to check to see if the group already exists before you save it. Maybe delete it if exists or add to the group.
Hope this helps
Edit: As it always seems to go, the error started popping up after I clicked submit. I'll tinker around a bit more, but will echo #royka in wondering if you really do need to give the same name to multiple shapes.
The below code seems to do what you're looking for (create the shapes, give them names and then group). In the grouping function, I left the "AroText" number the same just to see if an error would happen (it did not). It seems that both shapes have the same name, but what differentiates them is their Shape.ID. From what I can tell, if you say ActiveSheet.Shapes("My Group").Select, it will select the element with that name with the lowest ID (as to why it lets you name two things the same name, no clue :) ).
It isn't quite an answer to your question of "why" (I wasn't able to replicate the error), but this will hopefully give you one way "how".
Sub SOTest()
Dim Arrow As Shape
Dim TextBox As Shape
Dim i as Integer
Dim Grouper As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
' Make two shapes and group, naming the group the same in both cases
For i = 1 To 2
' Create arrow with name "Aro" & i
Set Arrow = ws.Shapes.AddShape(msoShapeRightArrow, 10, 50, 30, 30)
Arrow.Name = "Aro" & i
' Create text box with name "Text" & i
Set TextBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 50, 40, 40)
TextBox.Name = "Text" & i
' Use a group function to rename the shapes
Set Grouper = CreateGroup(ws, Arrow, TextBox, i)
' See the identical names but differing IDs
Debug.Print "Name: " & Grouper.Name & " | ID: " & Grouper.ID
Next
End Sub
Function CreateGroup(ws As Worksheet, Arrow As Shape, TextBox As Shape, Number As Integer) As Variant
Dim arrowBoxGroup As Variant
' Group the provided shapes and change the name
Set arrowBoxGroup = ws.Shapes.Range(Array(Arrow.Name, TextBox.Name)).Group
arrowBoxGroup.Name = "AroTxt" & Number
' Return the grouped object
Set CreateGroup = arrowBoxGroup
End Function