あとで、解説を書く
まず、コードを質問者さんへ送る
Option Explicit '起動済みの既存 パワーポイントのスライドから 'パワポのシェイプ情報をexcelシートへ書き出す 'ex:新規ブックを追加して、pp:スライドの情報をex:シート単位で貼り付ける '2024/04/04 シェイプでHasChart = True だったら、グラフの情報を書きだす Const 基準セル = "B2" Sub test20240404_01ppスライドをexシートへグラフ情報付きで書き出す() Dim ppApp As Object 'As PowerPoint.Application Set ppApp = Nothing 'エラーチェックのため初期化 On Error Resume Next '取得エラー時に次へ行く Set ppApp = GetObject(, "PowerPoint.Application") On Error GoTo 0 'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意 If ppApp Is Nothing Then MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね" Exit Sub End If '新規に貼り付け先のExcelブックを作成したいので Dim wbNEW As Workbook Set wbNEW = Workbooks.Add '新規ブックの追加 Dim shNEW As Worksheet '新規のシート用に変数を作成する Dim p As Integer, y As Integer 'pページ、y行 Dim objShape As Object 'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか Dim n As Integer, x As Integer '系列のカウンター,セットする列位置 'パワポのスライドをExcelシートに For p = 1 To ppApp.ActivePresentation.Slides.Count 'スライド数ループ pページ '新規シートの追加 Set shNEW = wbNEW.Sheets.Add(Before:=wbNEW.Worksheets(wbNEW.Worksheets.Count)) shNEW.Name = "スライド" & p 'シート名をスライド1,2,3..にする '新規シートを一番後ろに追加するために↑細工してみた 'ここから、シェイプの情報を書きこむ '書き込み開始位置の左上のセルを指定して、offictで対応する Dim rBASE As Range '拠点、書き込みの左上を代入する Set rBASE = shNEW.Range(基準セル) rBASE.Select '0行目に見出しを書き込む rBASE.Offset(0, 0) = "Page番号" rBASE.Offset(0, 1) = "ID" rBASE.Offset(0, 2) = "名前 Shape.Name" rBASE.Offset(0, 3) = "種類 .Type" '※あると便利 rBASE.Offset(0, 4) = "左位置.Left" '位置等で絞り込む？時、便利 rBASE.Offset(0, 5) = "上位置.Top" rBASE.Offset(0, 6) = "幅 .Width" '幅と高さ 24/03/02 rBASE.Offset(0, 7) = "高さ .Height" rBASE.Offset(0, 8) = "テキスト 先頭から10文字" 'テキストがあれば判断時便利かな？ 'pページのスライド内のシェイプを探る y = 1 '基準の一つ下からセットする For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes rBASE.Offset(y, 0) = p 'スライド番号(ページ番号) rBASE.Offset(y, 1) = objShape.ID 'IDで今回、区別したいので※24/03/02追加 rBASE.Offset(y, 2) = objShape.Name 'オブジェクトの名前 rBASE.Offset(y, 3) = objShape.Type '※種類 rBASE.Offset(y, 4) = objShape.Left '位置 左上の左 判断材料 rBASE.Offset(y, 5) = objShape.Top '位置 左上の縦 rBASE.Offset(y, 6) = objShape.Width ' rBASE.Offset(y, 7) = objShape.Height 'オブジェクトがテキストを持っているか？チェックしてからセット If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり rBASE.Offset(y, 8) = Left(objShape.TextFrame.TextRange.Text, 10) 'テキストを10文字だけ書き込む↑,99文字など好みの文字で End If End If '2024/04/04 追加 'オブジェクトがグラフを持っているか？ HasChartをチェックしてからセット If objShape.HasChart = True Then Debug.Print "チャートみつけたぞ", objShape.Chart.Name Dim ppChart As Object 'PowerPoint.Chart Set ppChart = objShape.Chart 'シェイプの下にあるChartを変数に代入 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 2) = ".SeriesCollection.Count=" & ppChart.SeriesCollection.Count '系列の数だけ回す For n = 1 To ppChart.SeriesCollection.Count Dim ppSeries As Object 'PowerPoint.Series '系列を処理する Set ppSeries = objShape.Chart.SeriesCollection(n) 'n番目の系列を代入 '系列の名前 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 2) = "Series.Name=" & ppSeries.Name 'グラフの種類によって、どっちを先にする？キレイな表を作りたかったり。 'Series.XValuesを表示 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 1) = "XValues" rBASE.Offset(y, 2) = ppSeries.Name '系列の名前 Dim boxXValues As Variant boxXValues = ppSeries.XValues For x = 1 To UBound(boxXValues) rBASE.Offset(y, 2 + x) = boxXValues(x) Next 'Series.Valuesを表示 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 1) = "Values" rBASE.Offset(y, 2) = ppSeries.Name '系列の名前 Dim boxValues As Variant boxValues = ppSeries.Values For x = 1 To UBound(boxValues) rBASE.Offset(y, 2 + x) = boxValues(x) Next Next End If y = y + 1 'セットする行を次へ Next Next MsgBox "処理終了、確認してください" End Sub
https://youtu.be/RD5ovhJncsY
目次
00:00 あいさつ、やりたいこと
01:19 1.1 実行結果を見せる
06:09 1.2 Excelのリンクを切る
08:40 1.3 ソースコードの貼り付け方
12:01 2.1 先月作成のコードを宣伝紹介 PowerPointのシェイプ情報をExcelへ書き出す
13:43 2.2 昨年23年から積み残しのコード グラフの情報 Values,XValuesを使用します
2.3 今回作成した パワポのグラフから値をExcelシートへ書き込む テストコード
14:35 2.3.1 Shape.HasChart で シェイプがグラフか？判断する
16:04 2.3.2 系列の数 と 名前
17:51 2.3.3 Series.XValuesを表示
19:02 2.3.4 Series.Valuesを表示
20:28 2.3.5 ソースコード全体
24:24 2.4 急に脱線して出力結果の仕様変更を行う
28:06 2.4.1 系列が入れ替わっている場合
33:21 3.問題点・改善点 3.1 Series.Values Series.XValues の表示順や同じ値は一つにしたい
33:54 3.2 正規のリンク貼り付け？に対応していない 貼付け手順によってタイプが違う
35:21 単純な、手順 ショートカットで何も考えないで貼り付ける
36:04 形式を選択して貼付で選ぶ 貼付けパターンが三種類テストしてみます
38:53 元Excelの値を変更して再テスト
42:01 グラフのタイプ Shape.Type を説明する 4.終わりの挨拶
youtu.be
パワポのグラフから値を取り出すソースコード:
24:24 2.4 急に脱線して出力結果の仕様変更を行う
突然、客先で修正を始める、迷惑プログラマーの姿・・・※反省しないとなぁ・・・
説明が飛んでしまい、迷惑をかけます
https://www.youtube.com/watch?v=RD5ovhJncsY&t=1464
Option Explicit '起動済みの既存 パワーポイントのスライドから 'パワポのシェイプ情報をexcelシートへ書き出す 'ex:新規ブックを追加して、pp:スライドの情報をex:シート単位で貼り付ける '2024/04/04 シェイプでHasChart = True だったら、グラフの情報を書きだす Const 基準セル = "B2" Sub test20240404_01ppスライドをexシートへグラフ情報付きで書き出す() Dim ppApp As Object 'As PowerPoint.Application Set ppApp = Nothing 'エラーチェックのため初期化 On Error Resume Next '取得エラー時に次へ行く Set ppApp = GetObject(, "PowerPoint.Application") On Error GoTo 0 'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意 If ppApp Is Nothing Then MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね" Exit Sub End If '新規に貼り付け先のExcelブックを作成したいので Dim wbNEW As Workbook Set wbNEW = Workbooks.Add '新規ブックの追加 Dim shNEW As Worksheet '新規のシート用に変数を作成する Dim p As Integer, y As Integer 'pページ、y行 Dim objShape As Object 'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか Dim n As Integer, x As Integer '系列のカウンター,セットする列位置 'パワポのスライドをExcelシートに For p = 1 To ppApp.ActivePresentation.Slides.Count 'スライド数ループ pページ '新規シートの追加 Set shNEW = wbNEW.Sheets.Add(Before:=wbNEW.Worksheets(wbNEW.Worksheets.Count)) shNEW.Name = "スライド" & p 'シート名をスライド1,2,3..にする '新規シートを一番後ろに追加するために↑細工してみた 'ここから、シェイプの情報を書きこむ '書き込み開始位置の左上のセルを指定して、offictで対応する Dim rBASE As Range '拠点、書き込みの左上を代入する Set rBASE = shNEW.Range(基準セル) rBASE.Select '0行目に見出しを書き込む rBASE.Offset(0, 0) = "Page番号" rBASE.Offset(0, 1) = "ID" rBASE.Offset(0, 2) = "名前 Shape.Name" rBASE.Offset(0, 3) = "種類 .Type" '※あると便利 rBASE.Offset(0, 4) = "左位置.Left" '位置等で絞り込む？時、便利 rBASE.Offset(0, 5) = "上位置.Top" rBASE.Offset(0, 6) = "幅 .Width" '幅と高さ 24/03/02 rBASE.Offset(0, 7) = "高さ .Height" rBASE.Offset(0, 8) = "テキスト 先頭から10文字" 'テキストがあれば判断時便利かな？ 'pページのスライド内のシェイプを探る y = 1 '基準の一つ下からセットする For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes rBASE.Offset(y, 0) = p 'スライド番号(ページ番号) rBASE.Offset(y, 1) = objShape.ID 'IDで今回、区別したいので※24/03/02追加 rBASE.Offset(y, 2) = objShape.Name 'オブジェクトの名前 rBASE.Offset(y, 3) = objShape.Type '※種類 rBASE.Offset(y, 4) = objShape.Left '位置 左上の左 判断材料 rBASE.Offset(y, 5) = objShape.Top '位置 左上の縦 rBASE.Offset(y, 6) = objShape.Width ' rBASE.Offset(y, 7) = objShape.Height 'オブジェクトがテキストを持っているか？チェックしてからセット If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり rBASE.Offset(y, 8) = Left(objShape.TextFrame.TextRange.Text, 10) 'テキストを10文字だけ書き込む↑,99文字など好みの文字で End If End If '2024/04/04 追加 'オブジェクトがグラフを持っているか？ HasChartをチェックしてからセット If objShape.HasChart = True Then Debug.Print "チャートみつけたぞ", objShape.Chart.Name Dim ppChart As Object 'PowerPoint.Chart Set ppChart = objShape.Chart 'シェイプの下にあるChartを変数に代入 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 2) = ".SeriesCollection.Count=" & ppChart.SeriesCollection.Count '系列の数だけ回す For n = 1 To ppChart.SeriesCollection.Count Dim ppSeries As Object 'PowerPoint.Series '系列を処理する Set ppSeries = objShape.Chart.SeriesCollection(n) 'n番目の系列を代入 If n = 1 Then '初回のみ落とす '系列の名前 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 2) = n 'グラフの種類によって、どっちを先にする？キレイな表を作りたかったり。 'Series.XValuesを表示 'rBASE.Offset(y, 3) = ppSeries.Name '系列の名前 Dim boxXValues As Variant boxXValues = ppSeries.XValues For x = 1 To UBound(boxXValues) rBASE.Offset(y, 3 + x) = boxXValues(x) Next End If 'Series.Valuesを表示 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 2) = n rBASE.Offset(y, 3) = ppSeries.Name '系列の名前 Dim boxValues As Variant boxValues = ppSeries.Values For x = 1 To UBound(boxValues) rBASE.Offset(y, 3 + x) = boxValues(x) Next Next End If y = y + 1 'セットする行を次へ Next Next MsgBox "処理終了、画像を確認してください" End Sub
解説位置:
https://www.youtube.com/watch?v=RD5ovhJncsY&t=1464
パワーポイント リンク切れグラフの値を取り出す PowerPoint マクロ VBA
https://www.youtube.com/playlist?list=PL8vZhsyiiFhuAVnLl4S9tWujchW7rqOUm
再生リスト↑貼り付けたExcelグラフがリンク切れ 値を救いたい 吸い出したい
