PowerPoint Shuffle (swap) objects on PPT slides with the same name only

[Mayday67]

Hi,

I am making a workbook for students and I want to be able to shuffle objects (shapes, textboxes, anything) randomly but in a way that they only swap places between each other if they have the same name (one group - TextBox 1, TextBox 2, TextBox 3, TextBox 4...., second group Photo 1, Photo 2, Photo 3, third group - Shape 1 Shape 2....)

On one slide I have 4 text boxes on specific locations and 4 photos and 4 shapes, I want them to shuffle around but so that photo 1 goes to either place of photo 2 3 or 4, textbox 1 to go to either place of tb 234 and vice versa.

All shapes and objects have the same size.

This VBA code shuffles everything on the slides (not what I want).

Can anyone help?

Thank you.

Sub ShuffleShapesAll()​

Dim oSlide As Slide, oShape As Shape, iShapesCount As Integer

For kp = 1 To ActivePresentation.Slides.Count

Set oSlide = ActivePresentation.Slides(kp)

iShapesCount = oSlide.Shapes.Count

Dim sMsg As String

If iShapesCount < 2 Then

sMsg = "To run the program, more than one shape are needed in the current slide!"

MsgBox sMsg, vbInformation, "Procedure Canceled"

Exit Sub

End If

Dim oShapesNum()

ReDim oShapesNum(iShapesCount)

Dim i As Integer

Dim iLeft As Double, iTop As Double, iHeight As Double, iWidth As Double

Dim oShapesArr() As Double

ReDim oShapesArr(iShapesCount, 3)

For i = 1 To iShapesCount

oShapesNum(i) = i

With oSlide.Shapes(i)

oShapesArr(i, 0) = .Left

oShapesArr(i, 1) = .Top

oShapesArr(i, 2) = .Height

oShapesArr(i, 3) = .Width

End With

Next i

Dim oShuffledArr As Variant

oShuffledArr = SuffleNoReplace(oShapesNum)

Dim iNum As Integer

For i = 1 To iShapesCount

iNum = oShuffledArr(i)

With oSlide.Shapes(i)

iLeft = oShapesArr(iNum, 0)

iTop = oShapesArr(iNum, 1)

iHeight = oShapesArr(iNum, 2)

iWidth = oShapesArr(iNum, 3)

.Left = iLeft

.Top = iTop

.Height = iHeight

.Width = iWidth

End With

Next i

Next

End Sub


Function ShuffleNoReplace

Dim iDim As Integer

iDim = UBound(oArr)

Randomize Timer

'Dim i As Integer, aVal As Integer, ok As Boolean, bVal As Integer, tmp As Integer

Dim i, aVal, ok As Boolean, bVal, tmp

If iDim = 2 Then

oArr(1) = 2

oArr(2) = 1

GoTo endFunc


End If


For i = 1 To iDim

aVal = i 'sujet A

ok = False

While ok = False


bVal = aVal

While bVal = aVal

bVal = Int(iDim * Rnd) + 1

Wend

If oArr(bVal) <> aVal And oArr(aVal) <> bVal Then

tmp = oArr(aVal): oArr(aVal) = oArr(bVal): oArr(bVal) = tmp

ok = True

End If

Wend

Next

endFunc:

SuffleNoReplace = oArr

' For i = 1 To iDim

' Debug.Print oArr(i)

' Next

End Function