Sub myTitlePptToXlsRows()
  Rem タイトル一括Excel転記処理
  Rem 記録者:Hitrock Camellia Shinopy
  Rem 言語:PowerPoint VBA
  Rem 機能:各プレゼンテーションのスライドにあるタイトルをExcelの各列へ転記する。
  Rem 注記:プレゼンテーションのファイルを開いておき(複数可)、
  Rem myTitlePptToXlsを起動して使用。
  Rem 第1版:2004/08/04:作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定:Microsoft Excel 10.0 Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem Dim myExcel As Excel.Application
  Dim myExcel As Variant  ' <= 参照設定をしない場合、Variantを指定する。
  Dim myPres As PowerPoint.Presentation
  Dim mySlide As Slide
  Dim myLine As Long
  Dim myClmn As Long
  '
  myClmn = 0
  Set myExcel = CreateObject("Excel.Application")
  myExcel.Workbooks.Add
  myExcel.Range("A1").Select
  myExcel.Visible = True
  '
  For Each myPres In Presentations
    myClmn = myClmn + 1
    myLine = 0
    For Each mySlide In myPres.Slides
      
      myLine = myLine + 1
      If mySlide.Shapes.HasTitle Then
        myExcel.Cells(myLine, myClmn).Value = _
          mySlide.Shapes.Title.TextFrame.TextRange.Text
      Else
        myExcel.Cells(myLine, 1).Value = "( Untitled )"
      End If
    Next mySlide
  Next myPres
  '
  Set myExcel = Nothing
End Sub  '  myTitlePptToXlsRows
inserted by FC2 system