我有一个演示文稿，其中包含 32 张外观相同的幻灯片(最初是宏生成的，后来有了人情味(。
简化外观：
标题(但未格式化为标题(
图片
内容1
内容2 内容3
我现在想将文本复制回 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
最终帮助我的是将每个文本框的左侧和顶部位置相乘。该值足够唯一，足以使相关内容最终出现在每张幻灯片的同一列中。在Excel中对列本身进行排序，我仍然需要手动完成，但这是一项简单的任务。我从另一个堆栈溢出问题中获得的快速排序算法
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