Copy Powerpoint Shapes to Excel - identically looking slides, different shape order - vba

Question

I have a presentation with 32 identically looking slides (initally macro generated, later had human touch).
Simplified look:
Title (not formatted as a headline, though)
picture
Content1
Content2
Content3
I now want to copy the text back to Excel. Although all slides look identical, the order of the shapes in slide.Shapes seems different.
For every slide I want a row, with the colums in the same order: Title, Content1, Content2,Content3 but some are Content1,Content3,Title,Content2
(or any other order)
Why is this?
My code:
Sub CopyFromPowerpoint()
'Prepare variables
Dim PowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim curShape As PowerPoint.shape
Dim RowCounter As Integer
Dim ColumnCounter As Integer
Dim tmp As String
'Set powerPoint
Set PowerPoint = GetObject(, "PowerPoint.Application")
tmp = "XXX" 'this should never be pasted
RowCounter = 1
ColumnCounter = 1
For Each Slide In PowerPoint.Presentations(1).Slides
Set activeSlide = PowerPoint.Presentations(1).Slides(RowCounter)
For Each shape In activeSlide.Shapes
Set curShape = activeSlide.Shapes(ColumnCounter)
If curShape.TextFrame.HasText Then tmp = curShape.TextFrame.TextRange
If curShape.TextFrame.HasText Then Worksheets("nameofsheet").Cells(RowCounter, ColumnCounter).Value = tmp
ColumnCounter = ColumnCounter + 1
Next
ColumnCounter = 1
RowCounter = RowCounter + 1
Next
End Sub

Answer 1

What helped me in the end was multiplying the left and top position for each textbox. That value was unique enough for the relevant content to end up in the same column for each slide. Ordering the columns themselves in Excel, I still needed to do manually but that was an easy task. The quick sort algorithm I got from another stackoverflow question
Sub CopyFromPowerpoint()
'Prepare variables
Dim PowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim curShape As PowerPoint.shape
Dim RowCounter As Integer
Dim ColumnCounter As Integer
Dim shapeCounter As Long
Dim tmp(20) As String
Dim arr(20) As Long
Dim tmpMult As Long
'Set powerPoint
Set PowerPoint = GetObject(, "PowerPoint.Application")
RowCounter = 1
ColumnCounter = 1
For Each Slide In PowerPoint.Presentations(1).Slides
Set activeSlide = PowerPoint.Presentations(1).Slides(RowCounter)
'Loop through shapes, note their position from top and left, multiply them and sort it
shapeCounter = LBound(arr)
For Each shape In activeSlide.Shapes
arr(CInt(shapeCounter)) = shape.Top * shape.Left
shapeCounter = shapeCounter + 1
Next
Call QuickSort(arr, LBound(arr), UBound(arr))
'Loop through shapes again and copy shape text into relevant position in text array
For Each shape In activeSlide.Shapes
If shape.TextFrame.HasText Then
For i = LBound(arr) To UBound(arr)
tmpMult = shape.Top * shape.Left
If arr(i) = tmpMult Then tmp(i) = shape.TextFrame.TextRange
tmpMult = 0
Next i
End If
Next
'Loop through text array and paste into worksheet
For i = LBound(tmp) To UBound(tmp)
Worksheets("uebergabe").Cells(RowCounter, i + 1).Value = tmp(i)
Next i
'Reset for next slide
RowCounter = RowCounter + 1
shapeCounter = 0
For i = LBound(arr) To UBound(arr)
arr(i) = 0
tmp(i) = ""
Next i
Next
End Sub
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub