試圖將幻燈片標題從PowerPoint復制到Excel

Question

我對excel VBA還是很陌生，我想將所有幻燈片中的幻燈片標題從PPT復制到Excel（粘貼，然后轉到下一行並粘貼）

但是目前，我只能拿出以下看起來很愚蠢的代碼。 如果有人可以簡化我的代碼，以便有100多個幻燈片，我不必重復那么多的代碼行，將不勝感激

Sub CopySlideTitle()
'Stupid way of doing things
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoTrue
ppt.Presentations.Open ("C:\Users\geral\Desktop\Test.pptm")
Dim ppPres As PowerPoint.Presentation
Set ppPres = ppt.ActivePresentation

Dim ppSlide As Slide


Dim SlideText01 As String, SlideText02 As String, SlideText03 As String, _
SlideText04 As String, SlideText05 As String, SlideText06 As String, _
SlideText07 As String, SlideText08 As String, SlideText09 As String, _
SlideText10 As String

SlideText01 = ppPres.Slides(1).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText02 = ppPres.Slides(2).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText03 = ppPres.Slides(3).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText04 = ppPres.Slides(4).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText05 = ppPres.Slides(5).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText06 = ppPres.Slides(6).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText07 = ppPres.Slides(7).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText08 = ppPres.Slides(8).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText09 = ppPres.Slides(9).Shapes("SlideTitle").TextFrame.TextRange.Text
SlideText10 = ppPres.Slides(10).Shapes("SlideTitle").TextFrame.TextRange.Text

Range("A1").Value = SlideText01
Range("A2").Value = SlideText02
Range("A3").Value = SlideText03
Range("A4").Value = SlideText04
Range("A5").Value = SlideText05
Range("A6").Value = SlideText06
Range("A7").Value = SlideText07
Range("A8").Value = SlideText08
Range("A9").Value = SlideText09
Range("A10").Value = SlideText10

End Sub

預先感謝數百萬

Answer 1

您可以按以下步驟循環瀏覽每張幻燈片...

Sub CopySlideTitle()

    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim oRow As Long

    Set ppApp = New PowerPoint.Application
    ppApp.Visible = msoTrue

    Set ppPres = ppApp.Presentations.Open("C:\Users\geral\Desktop\Test.pptm")

    oRow = 1
    For Each ppSlide In ppPres.Slides
        Cells(oRow, "A").Value = ppSlide.Shapes("SlideTitle").TextFrame.TextRange.Text
        oRow = oRow + 1
    Next ppSlide

End Sub

但是，這是另一種方式。 此方法循環遍歷每個幻燈片，然后循環遍歷幻燈片中的每個占位符，然后檢查占位符是否為標題，然后檢索其文本。

Sub CopySlideTitle()

    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppPlaceHolder As PowerPoint.Shape
    Dim oRow As Long

    Set ppApp = New PowerPoint.Application
    ppApp.Visible = msoTrue

    Set ppPres = ppApp.Presentations.Open("C:\Users\geral\Desktop\Test.pptm")

    oRow = 1
    For Each ppSlide In ppPres.Slides
        For Each ppPlaceHolder In ppSlide.Shapes.Placeholders
            If ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderTitle Then
                Cells(oRow, "A").Value = ppPlaceHolder.TextFrame.TextRange.Text
                oRow = oRow + 1
                Exit For
            End If
        Next ppPlaceHolder
    Next ppSlide

End Sub

另外，如果要在“標題”頁面中包含標題，則需要替換...

If ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderTitle Then

與

If ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderCenterTitle Or _
                ppPlaceHolder.PlaceholderFormat.Type = ppPlaceholderTitle Then

希望這可以幫助！