I'm writing a macro to add a shape on top of a picture (ActiveX) when it's clicked on:
Private Sub clickpic_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
ClickShape CLng(x), CLng(y)
End Sub
Public addedShapes() As Shape
Public sIndex As Integer
Sub ClickShape(x As Long, y As Long)
Dim shp As Shape
Application.ScreenUpdating = False
Set shp = ActiveSheet.Shapes.AddShape(msoShapeMathMultiply, x + ActiveSheet.Shapes("clickpic").Left - 10, _
y + ActiveSheet.Shapes("clickpic").Top - 10, 20, 20)
With shp.Fill
.ForeColor.RGB = RGB(255, 0, 0)
.backColor.RGB = RGB(255, 0, 0)
End With
shp.Line.Visible = False
shp.Name = CStr(shp.Top & shp.Left)
ReDim Preserve addedShapes(sIndex)
sIndex = sIndex + 1
Set addedShapes(UBound(addedShapes)) = shp
ActiveSheet.Shapes("clickpic").Visible = False
ActiveSheet.Shapes("clickpic").Visible = True
Application.ScreenUpdating = True
End Sub
I've found the only way to display the shape immediately is to enable and disable the picture:
ActiveSheet.Shapes("clickpic").Visible = False
ActiveSheet.Shapes("clickpic").Visible = True
However, despite turning screen updating off this still causes the screen to refresh / flicker. Any idea how I can prevent this?
Read somewhere that Visible = True/False may trigger recalculation of the sheet, which may cause the flicker. It's worth trying to set calculation to manual during your code.
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 would like to add bookmarks of audio and
associate them to the TriggerBookmark property of the Timing Object in VBA.
To Add Bookmarks this Function does the job :
Function AddBookMark(ByRef MediaObject As Shape, ByVal PositionInMs As Long, ByVal BookMarkName As String) As MediaBookmark
Dim Result As MediaBookmark
With MediaObject
Set Result = .MediaFormat.MediaBookmarks.Add(Position:=PositionInMs, name:=BookMarkName)
End With
Set AddBookMark = Result
End Function
This code below
Adds the media object
Adds 2 bookMarks to that media object
Adds A rectangle Shape
Create and effect and an AnimationBehaviour
The animation works but I would like to launch the motion effect based on the created bookmarks.
The 2 Commented lines does not work.
Does SomeOne understand why?
Sub SetBookMarkAsTriggerTest()
FileName = "C:\path\to\your.mp3"
Dim Slide As Slide
Dim MediaObject As Shape
Dim AnimatedShape As Shape
Dim FirstBookMark As MediaBookmark
Dim SecondBookMark As MediaBookmark
Dim FirstEffect As Effect
Dim SecondEffect As Effect
Dim Behaviour As AnimationBehavior
Set Slide = ActivePresentation.Slides(1)
Set MediaObject = Slide.shapes.AddMediaObject2(FileName, msoTrue,_
msoTrue, 50, 50)
MediaObject.name = "MediaOBject1"
Set FirstBookMark = AddBookMark(MediaObject, 5000, "bm1")
Set SecondBookMark = AddBookMark(MediaObject, 7000, "bm2")
Set AnimatedShape = Slide.shapes.addShape(msoShapeRectangle, _
0, 0, 100, 50)
Set FirstEffect = Slide.TimeLine.MainSequence.AddEffect(Shape:=AnimatedShape, _
EffectId:=msoAnimEffectFade, Trigger:=msoAnimTriggerAfterPrevious)
FirstEffect.Timing.Duration = 10
Set Behaviour = FirstEffect.Behaviors.Add(msoAnimTypeMotion)
With Behaviour
With .motionEffect
.FromX = 0
.FromX = 0
.ToX = 50
.ToY = 50
End With
With .Timing
.Duration = 2
'this line does not work...why ?
'.TriggerType = msoAnimTriggerOnMediaBookmark
'this line does not work neither...why ?
'.TriggerBookmark = "bm1"
End With
End With
End Sub
Thanks a lot!
I managed to do what I wanted by using the InteractiveSequences.
We Can then add a trigger effect with the AddTriggerEffect method based on a bookmark As Follow :
Function AddBookMark(ByRef MediaObject As Shape, ByVal PositionInMs As Long, ByVal BookMarkName As String) As MediaBookmark
Dim result As MediaBookmark
With MediaObject
Set result = .MediaFormat.MediaBookmarks.Add(Position:=PositionInMs, Name:=BookMarkName)
End With
Set AddBookMark = result
End Function
Sub SetBookMarkAsTriggerTest()
fileName = "C:\path\to\your.mp3"
Dim Slide As Slide
Dim MediaObject As Shape
Dim AnimatedShape As Shape
Dim FirstBookMark As MediaBookmark
Dim FirstEffect As effect
Dim Behaviour As AnimationBehavior
Set Slide = ActivePresentation.Slides(1)
Set MediaObject = Slide.shapes.AddMediaObject2(fileName, msoTrue, _
msoTrue, 50, 50)
MediaObject.Name = "MediaOBject1"
Set FirstBookMark = AddBookMark(MediaObject, 5000, "bm1")
Set AnimatedShape = Slide.shapes.AddShape(msoShapeRectangle, _
0, 0, 100, 50)
Dim Sequence As Sequence: Set Sequence = Slide.TimeLine.InteractiveSequences.Add(1)
Set FirstEffect = Sequence.AddTriggerEffect(pShape:=AnimatedShape, effectId:=msoAnimEffectAppear, _
trigger:=msoAnimTriggerOnMediaBookmark, pTriggerShape:=MediaObject, BookMark:="bm1")
End Sub
I am receiving a run-time error '1004' on the line .Font.color = vbRed when setting conditional formats. The Sub works great on Excel 2011 for Mac, but fails on Windows.
I've tried rearranging the code, using RGB(255,0,0), setting .ColorIndex, as well as recording a macro and using that code. All failed in windows.
I'm trying to set the font color to red if the cell begins with "Med". The sub is called from here:
Public Const BASE As String = "$D$14"
Dim cols As Long
Dim rows As Long
Dim applyToRange As Range
Dim condition As String
' rows and cols variables set here...
Set applyToRange = Range(BASE, Range(BASE).Offset(rows - 1, cols - 1))
' Med
condition = "Med"
applyTextStringConditionals applyToRange, condition, xlBeginsWith, 0, False
What am I missing?
Private Sub applyTextStringConditionals(ByVal applyToRange As Range, ByVal matchString As String, _
ByVal operator As Long, ByVal color As Long, ByVal stopIfTrue As Boolean)
applyToRange.FormatConditions.Add Type:=xlTextString, String:=matchString, TextOperator:=operator
applyToRange.FormatConditions(applyToRange.FormatConditions.Count).SetFirstPriority
If color = 0 Then
With applyToRange.FormatConditions(1)
.Font.color = vbRed '<--- Error 1004 here
'.TintAndShade = 0
End With
Else
applyToRange.FormatConditions(1).Interior.color = color
End If
applyToRange.FormatConditions(1).stopIfTrue = stopIfTrue
End Sub
UPDATE:
This works, only if it's the first conditional format created:
Set applyToRange = Range(BASE, Range(BASE).Offset(rows - 12, cols - 1))
' Med
condition = "Med"
Stop
applyToRange.FormatConditions.Add Type:=xlTextString, String:=condition, TextOperator:=xlBeginsWith
applyToRange.FormatConditions(applyToRange.FormatConditions.Count).SetFirstPriority
applyToRange.FormatConditions(1).Font.Color = vbRed '-16776961
applyToRange.FormatConditions(1).stopIfTrue = True
But this does not:
Private Sub applyTextStringConditionals(ByVal l_applyToRange As Range, ByVal matchString As String, _
ByVal l_Operator As Long, ByVal setColor As Long, ByVal l_stopIfTrue As Boolean)
l_applyToRange.FormatConditions.Add Type:=xlTextString, String:=matchString, TextOperator:=l_Operator
l_applyToRange.FormatConditions(l_applyToRange.FormatConditions.Count).SetFirstPriority
If setColor = 0 Then
l_applyToRange.FormatConditions.Item(1).Font.Color = vbRed
Else
l_applyToRange.FormatConditions(1).Interior.Color = setColor
End If
l_applyToRange.FormatConditions(1).stopIfTrue = True
end sub
I am looking to create custom pop up displays on a chart using vba.
Like this except instad of "Value: 6" display the corresponding comment. "Yes"
Here is an article with an example workbook that shows a textbox when hovering over a point on the chart. The explanations on the website are not detailed enough for me to understand what is going on. When I try and modify the example workbook it stops functioning.
Is there a method to tracing excel vba code to discover what it is doing? Or, is there a better simple method for creating custom tooltips with excel charts?
Thanks.
Creating a chart (as a new sheet, not an embedded chart) and editing the VBA code for the sheet to:
Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
Dim ElementID As Long
Dim Arg1 As Long
Dim Arg2 As Long
Dim chart_data As Variant
Dim chart_label As Variant
Dim last_bar As Long
Dim chrt As Chart
Dim ser As Series
On Error Resume Next
Me.GetChartElement x, y, ElementID, Arg1, Arg2
Application.ScreenUpdating = False
Set chrt = ActiveChart
Set ser = ActiveChart.SeriesCollection(1)
Set ser2 = ActiveChart.SeriesCollection(2)
chart_data1 = ser.Values
chart_label1 = ser.XValues
chart_data2 = ser2.Values
chart_label2 = ser2.XValues
Set txtbox = ActiveSheet.Shapes("hover")
If ElementID = xlSeries Then
If Err.Number Then
Set txtbox = ActiveSheet.Shapes.AddTextbox _
(msoTextOrientationHorizontal, x, y, 400, 120) 'Textbox size
txtbox.Name = "hover"
txtbox.Fill.Solid
txtbox.Fill.ForeColor.SchemeColor = 9
txtbox.Line.DashStyle = msoLineSolid
chrt.Shapes("hover").TextFrame.Characters.Text = "Insert text wanted to display here"
With chrt.Shapes("hover").TextFrame.Characters.Font
.Name = "Arial"
.Size = 14
.ColorIndex = 16
End With
last_bar = Arg2
End If
ser.Points(Arg2).Interior.ColorIndex = 44
txtbox.Left = 0 'textbox location
txtbox.Top = 0 'textbox location
Else
txtbox.Delete
ser.Interior.ColorIndex = 16
End If
Application.ScreenUpdating = True
End Sub
This created a textbox when the mouse movement was over an Element of "xlSeries".
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