Loop through slides and shapes to duplicate tables - vba

Question

I want to:
Loop through all slides in the active presentation
Loop through the shapes in the slide
If it's a table and width is <410 then position it, make a duplicate and position duplicate. (I should also be checking to see if there is another table on the slide but I couldn't get that to work.)
If it's a table and width is >880 then simply position it.
Repeat until done.
The code goes into an infinite loop when duplicating and repositioning the new shape.
Sub test()
Dim sld As Slide
Dim shp As Shape
Dim sr As Series
Dim chrt As Chart
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
With shp
MsgBox .Width
If .Width < 410 Then
MsgBox "<410"
.Top = 170
.Left = 35
.Width = 409
.Duplicate
.Top = 170
.Left = 515
.Width = 409
End If
If .Width > 880 Then
MsgBox ">880"
.Top = 170
.Left = 35
.Width = 889
End If
End With
End If
Next shp
Next sld
End Sub

Answer 1

You want to avoid looping over sld.Shapes if you might be adding shapes to the slide within the loop.
One way to do that is to first collect the tables in a Collection and then loop over that:
Sub test()
Dim sld As Slide
Dim shp As Shape, shp2 As Shape
Dim sr As Series
Dim chrt As Chart, col As Collection
For Each sld In ActivePresentation.Slides
'first collect any existing table(s) on the slide
Set col = New Collection
For Each shp In sld.Shapes
If shp.HasTable Then col.Add shp
Next shp
'check what was found
If col.Count = 1 Then
Set shp = col(1)
If shp.Width < 410 Then
shp.Top = 170
shp.Left = 35
shp.Width = 409
Set shp2 = shp.Duplicate.Item(1) 'duplicate and get a reference to the new table
shp2.Top = 170
shp2.Left = 515
shp2.Width = 409
ElseIf shp.Width > 880 Then
shp.Top = 170
shp.Left = 35
shp.Width = 889
End If
ElseIf col.Count > 1 Then
'>1 table found - what to do here?
End If
Next sld
End Sub