Question

我有一个演示文稿，有32个相同的幻灯片（最初生成宏，之后有人性化）。

简化外观：

标题（虽然没有格式化为标题）
图片
内容1
内容2
Content3

我现在想将文本复制回Excel。虽然所有幻灯片看起来相同，但幻灯片中形状的顺序似乎不同。

对于每张幻灯片，我想要一行，列的顺序相同：
标题，内容1，内容2，内容3，但有些是内容1，内容3，标题，内容2 （或任何其他顺序）

这是为什么？

我的代码：

    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 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

将Powerpoint形状复制到Excel - 相同的幻灯片，不同的形状顺序

1 个答案: