[[20190814180530]]　『PPTをXLSに出力したものを整形したい』（プライス）　ページの最後に飛ぶ

『PPTをXLSに出力したものを整形したい』（プライス）

VBA初心者です。
こちら(https://www.relief.jp/docs/018395.html )のマクロを使って、パワーポイントをエクセルに変換している最中です。

上記URLのマクロだとスライド番号・シェイプ・文字列毎に列ができるのですが、これを
【スライド番号/見出し(Titleシェイプ)/スライド内容(Title以外のシェイプを一つのセルに纏めたもの)/当該スライドへのリンク】
という形に整形したいのです。

以下のようにマクロを組んでいますが、スライド内容のマクロ部分をどのように組むか？　で悩んでおります。ページ毎にCONCATENATE関数で結合、という形がいいのかなとぼんやり思っているのですが具体的にどう書けばいいのかわからず……
また、当該スライドへのリンクもハイパーリンクとならず困っております。

～～～～～～～～～～～～～～

  Dim xls As Object
  Dim i As Long
  Dim txt As String
  Dim prs As String
  Dim sld As Slide
  Dim shp As Shape
  Dim a As Long
  Dim FileName As String
    FileName = ActivePresentation.Name
  Dim FilePath As String
    FilePath = ActivePresentation.Path

  Set xls = CreateObject("Excel.Application")
  With xls

    .Visible = True
    .Workbooks.Add
    .Range("A1").Value = "プレゼンテーション名"
    .Range("B1").Value = "ページ数"
    .Range("C1").Value = "シェイプ名"
    .Range("D1").Value = "コンテンツ"
    .Range("E1").Value = "元PPTリンク"

    i = 2
    For Each sld In ActivePresentation.Slides
      For Each shp In sld.Shapes
        If shp.HasTextFrame Then
          .Cells(i, "A").Value = FileName
          .Cells(i, "B").Value = sld.SlideNumber
          .Cells(i, "C").Value = shp.Name
          '垂直タブ・キャリッジリターンをExcelの改行に置換
          txt = shp.TextFrame.TextRange.Text
          txt = Replace(txt, Chr(11), vbLf)
          txt = Replace(txt, vbCr, vbLf)
          .Cells(i, "D").Value = txt
          Dim PPTlink As String
            PPTlink = FilePath & " \ " & FileName & " #" & sld.SlideNumber + 1
          .Cells(i, "E").Value = PPTlink
          i = i + 1
        End If
      Next shp
    Next sld

    .Columns("A:B").EntireColumn.AutoFit
    .Columns("D:D").ColumnWidth = 65
    .Range("A1", .Cells(i, "D")).VerticalAlignment = -4160 'xlTop
    .Range("A1", .Cells(i, "D")).WrapText = True
    .Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

  '「タイトル」を「Title」に統一
  .Range("C:C").Replace What:="タイトル", Replacement:="Title"

  '見出しシートを作成
  .Worksheets.Add
  .ActiveSheet.Name = "見出し"
  'ページ毎に「Title」シェイプのコンテンツを抽出
  With Worksheets("Sheet1").Range("A1")
        .AutoFilter Field:=3, Criteria1:="Title*"
        .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets("見出し").Range("A1")
        .AutoFilter
    End With
  'コンテンツシートを作成
    .Worksheets.Add
  .ActiveSheet.Name = "コンテンツ"
  'ページ毎にCONCATENATE関数で結合

  'ページ毎にタイトルとコンテンツを引き込み

  '参照シートの削除

  End With
  Set xls = Nothing
～～～～～～～～～～～～～～

また、PPTマクロについての質問となってしまい恐縮なのですが、これらのマクロを複数PPTで回すことは可能でしょうか？

ご教授いただければ幸いです。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

コメント返信：

[ 一覧(最新更新順) ]

[[20190814180530]] 『PPTをXLSに出力したものを整形したい』（プライス） ページの最後に飛ぶ

[[20190814180530]]　『PPTをXLSに出力したものを整形したい』（プライス）　ページの最後に飛ぶ