パワポのテキストをExcelに書き出す

Const sFileName as String ="パワポファイルをフルパスで"
Sub Export_PPT()
  Dim pptApp As PowerPoint.Application: Set pptApp = New PowerPoint.Application
  Dim pptFile As PowerPoint.Presentation
  Dim dStartTime As Date: dStartTime = Now()
  
  Set pptFile = pptApp.Presentations.Open(sFileName, msoTrue)
  Dim pptSlide As PowerPoint.Slide
  Dim pptShp As PowerPoint.Shape
  Dim nRow As Long: nRow = 2
  Dim i As Long: Dim j As Long
  
  Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
  ws.Cells.Clear
  
  ws.Range("A1") = "スライド番号"
  ws.Range("B1") = "シェイプ名"
  ws.Range("C1") = "行番号"
  ws.Range("D1") = "列番号"
  ws.Range("E1") = "テキスト"
  ws.Range("E:E").NumberFormatLocal = "@"
  For Each pptSlide In pptFile.Slides
    For Each pptShp In pptSlide.Shapes
      If pptShp.HasTextFrame Then
        If Replace(pptShp.TextFrame.TextRange.Text, Chr(11), vbLf) <> "" Then
        ws.Range("A" & nRow) = pptSlide.SlideNumber
        ws.Range("B" & nRow) = pptShp.Name
        ws.Range("E" & nRow) = Replace(pptShp.TextFrame.TextRange.Text, Chr(11), vbLf)
        nRow = nRow + 1
        End If
      ElseIf pptShp.HasTable Then
        For i = 1 To pptShp.Table.Rows.Count
          For j = 1 To pptShp.Table.Columns.Count
            If pptShp.Table.Cell(i, j).Shape.HasTextFrame Then
              If Replace(pptShp.Table.Cell(i, j).Shape.TextFrame.TextRange.Text, Chr(11), vbLf) <> "" Then
                ws.Range("A" & nRow) = pptSlide.SlideNumber
                ws.Range("B" & nRow) = pptShp.Name
                ws.Range("C" & nRow) = i
                ws.Range("D" & nRow) = j
                ws.Range("E" & nRow) = Replace(pptShp.Table.Cell(i, j).Shape.TextFrame.TextRange.Text, Chr(11), vbLf)
                nRow = nRow + 1
              End If
            End If
          Next j
        Next i
      End If
    
    
    Next pptShp
    DoEvents
  Next pptSlide
  
  pptFile.Close
  pptApp.Quit
  
  MsgBox "書き出したよ(所要時間:" & Format(Now() - dStartTime, "hh:mm:ss") & ")"
  

End Sub