Скопируйте PowerPoint Shapes в Excel - одинаково выглядящие слайды, другой порядок форм

Question

У меня есть презентация с 32 одинаково выглядящими слайдами (изначально сгенерированные макрокомандой, позже были сделаны человеком).

Упрощенный вид:

Заголовок (хотя и не отформатирован в качестве заголовка)
Изображение
Контент1
Контент2
Контент3

Я хочу сейчасскопировать текст обратно в Excel.Хотя все слайды выглядят одинаковыми, порядок фигур на слайде выглядит по-разному.

Для каждого слайда мне нужна строка с столбцами в том же порядке:
Заголовок, Content1, Content2, Content3
, но некоторые из них
Content1, Content3, Title, Content2 (или любой другой порядок)

Почему это так?

Мой код:

    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

В конце концов мне помогло умножение левой и верхней позиции для каждого текстового поля.Это значение было достаточно уникальным, чтобы релевантный контент попадал в один столбец для каждого слайда.Заказывая сами столбцы в Excel, мне все равно приходилось делать вручную, но это была простая задача.Алгоритм быстрой сортировки, полученный из другого вопроса stackoverflow

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