・リンク切れグラフの値を取り出す方法を詳しく教えてください
・Excelコードの貼り付けと実行
・簡単なコード説明
youtu.be
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.終わりの挨拶
#PowerPointVBA #ExcelVBA #リンク切れグラフ #リンク切れ #マクロ #グラフ #Series #Values #XValues #デバッグ
1.やりたいこと
質問メッセージをいただきました(質問、ありがとう、気軽に質問してください)
件名： PowerPointリンク切れExcelグラフから値を取り出すコードの作成依頼
Ken3様へ
新年度4月に入り、お忙しいことと存じます。
先日、パワーポイントでリンク切れしたExcelファイルから値を取り出す方法についての実験動画
を拝見しました。その中で、マクロを使用する方法が紹介されていましたが、
私自身がマクロに詳しくないため、理解が難しい状況です。そこで、お手数をおかけいたしますが、
走るコードを作成していただけないでしょうか？
Excelコードの貼り付けと実行ぐらいは出来ます。4/10(水)の会議資料で必要な値を20枚取り出すためのコードを、
4/8(月)までにメールで送っていただけると幸いです。
期間が短くて申し訳ありませんが、本当に困っており、ご協力いただけると助かります。もし不可能な場合でも、4/8(月)までにご連絡いただければ幸いです。お待ちしております。
よろしくお願いいたします。
01:19 1.1 実行結果を見せる
正常パターンから値を取り出す方法を実演する
06:09 1.2 Excelのリンクを切る
問題のExcelリンクを外す
削除されたり、名前が違ったりすると、エラーが発生する。
いつものように更新を押すと、エラーメッセージが表示されることを再現します。
※この状態から値を取得したい。
08:40 1.3 ソースコードの貼り付け方
test20240404_01ppスライドをexシートへグラフ情報付きで書き出す - 三流君のソースコード置き場
のコードをExcelに貼って、テストしてみてください。
2.ソースコードの簡単な解説 は、イラナイケドおいおい 注意事項を兼ねて
12:01 2.1 先月作成のコードを宣伝紹介 PowerPointのシェイプ情報をExcelへ書き出す
スクショもどきが入っていて、後で見ると意外と面白いかも？
PowerPointのシェイプ情報をExcelへ書き出す
https://www.youtube.com/watch?v=o0PVL1v27Ts&t=786
がスタートのシェイプの解説で、
ここから、ソースコード
ken3memo.hatenablog.com
で
'起動済みの既存 パワーポイントのスライドから 'パワポのシェイプ情報とイメージjpgをexcelシートへ書き出す 'ex:新規ブックを追加して、pp:スライドの情報をex:シート単位で貼り付ける Sub test20240312_03ppスライドをページ単位で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 strJPGNAME As String '一時保存する名前 strJPGNAME = ThisWorkbook.Path & "\ppスライドtemp.jpg" Dim picShape As Shape '挿入画像はShapeなので Dim p As Integer, y As Integer 'pページ、y行 Dim objShape As Object 'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか 'パワポのスライドをExcelシートに For p = 1 To ppApp.ActivePresentation.Slides.Count 'スライド数ループ pページ 'pp画像を用意する 単純に.Exportでテンポラリ画像を作成 ppApp.ActivePresentation.Slides(p).Export strJPGNAME, "JPG" DoEvents '↑jpgファイルを作成しているので、念のため '画像をシートへ貼る Pictures.InsertがActiveSheetだったので※後で調べる・・・ Set shNEW = wbNEW.Sheets.Add(Before:=wbNEW.Worksheets(wbNEW.Worksheets.Count)) '新規シートを一番後ろに追加するために↑細工してみた shNEW.Name = "スライド" & p 'シート名をスライド1,2,3..にする shNEW.Columns("A:A").ColumnWidth = 79.5 '列幅を変更する ' 画像を0,0へ 埋め込み形式で挿入 ファイル名,リンク,保存保持,left,top,Width,Height Set picShape = shNEW.Shapes.AddPicture(strJPGNAME, False, True, 0, 0, -1, -1) picShape.Name = "ppスライド" & p picShape.Width = 480 '挿入後幅を調整する 'ここから、シェイプの情報を書きこむ '書き込み開始位置の左上のセルを指定して、offictで対応する Dim rBASE As Range '拠点、書き込みの左上を代入する Set rBASE = shNEW.Range("B1") 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 y = y + 1 'セットする行を次へ Next Next MsgBox "処理終了、画像を確認してください" End Sub
ここに、
グラフの系列情報を書いてみます。
13:43 2.2 昨年23年から積み残しのコード グラフの情報 Values,XValuesを使用します
んっ？コードの説明を軽くもしていないので、
下記、リンクを見てください。※たらいまわしヨクナイ、ここで処理(説明)を完結させないと
グラフの情報は、
Values,XValuesをDebug.Print表示してみる
https://www.youtube.com/watch?v=rBKtD3WPcXY&t=695s
Seriesコレクションに(系列に)
データが残っているのか？
確認するために、
Values,XValuesを表示してみます。
'Series(系列)を受け取り、中身を表示する 'As PowerPoint.Series を 受け取り、 '.Name .Values .XValues を表示 Sub DebugPrintSeriesTest(ppSeries As PowerPoint.Series) Dim n As Long Debug.Print ".Name=" & ppSeries.Name 'Series.Valuesを表示 Dim boxValues As Variant boxValues = ppSeries.Values Debug.Print "Values:" & UBound(boxValues) & "個の配列" For n = 1 To UBound(boxValues) Debug.Print n, boxValues(n) Next 'Series.XValuesを表示 Dim boxXValues As Variant boxXValues = ppSeries.XValues Debug.Print "XValues:" & UBound(boxXValues); "個の配列" For n = 1 To UBound(boxXValues) Debug.Print n, boxXValues(n) Next End Sub
全ての系列を回してみます
https://www.youtube.com/watch?v=rBKtD3WPcXY&t=827s
と言っても、ただ
Call DebugPrintSeriesTest(ppseries)
を呼んだだけです。
'現在選択ページのグラフ 'SeriesCollection.Count 全ての 'Series .Name .Values .XValues を表示 Sub test002グラフを見つけて中身をDebugPrint() Dim n As Integer Dim nPAGE As Integer nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ Dim objSlide As PowerPoint.Slide 'スライド Set objSlide = ActivePresentation.Slides(nPAGE) '↑現在のページを変数に Dim objShape As PowerPoint.Shape 'シェイプ 'テストで選択ページの.Shapesを探る Debug.Print "Id", "Name" For Each objShape In objSlide.Shapes 'スライド内のシェイプ達を一つ一つあさる Debug.Print objShape.Id, objShape.Name objShape.Select 'わかりやすいように該当オブジェクトを選択 If objShape.HasChart = True Then Debug.Print "チャートみつけたぞ", objShape.Chart.Name Dim ppChart As PowerPoint.Chart Set ppChart = objShape.Chart Debug.Print ".SeriesCollection.Count=", ppChart.SeriesCollection.Count For n = 1 To ppChart.SeriesCollection.Count Dim ppSeries As PowerPoint.Series '系列を処理する Set ppSeries = objShape.Chart.SeriesCollection(n) 'n番目の系列を代入 '作成した、DebugPrint用のサブ関数を呼ぶ 2023/07/09テスト Call DebugPrintSeriesTest(ppSeries) 'シリーズを個別に渡す Next End If Next MsgBox "終了" End Sub
この、テストコードを長いけど、
合わせてみます。
2.3 今回作成した パワポのグラフから値をExcelシートへ書き込む テストコード
ポイントは、
14:35 2.3.1 Shape.HasChart で シェイプがグラフか？判断する
'オブジェクトがグラフを持っているか？ HasChartをチェックしてからセット If objShape.HasChart = True Then Debug.Print "チャートみつけたぞ", objShape.Chart.Name Dim ppChart As Object 'PowerPoint.Chart Set ppChart = objShape.Chart 'シェイプの下にあるChartを変数に代入
↑単純に、チェックしてから、変数に入れてます。
※As Objectにしているのは、参照設定しなくても、ExcelVBAで動作させたかったので。
(他のプロパティやメソッドを探る時は、参照設定して探ってください)
16:04 2.3.2 系列の数 と 名前
系列の数は、
ppChart.SeriesCollection.Count
と、シリーズのカウントです
あとは、
'系列の数だけ回す For n = 1 To ppChart.SeriesCollection.Count Dim ppSeries As Object 'PowerPoint.Series '系列を処理する Set ppSeries = objShape.Chart.SeriesCollection(n) 'n番目の系列を代入 ↑ここでも、また、変数ppSeries As PowerPoint.Seriesに入れてから、 '系列の名前 y = y + 1 'セットする行を次の行へ rBASE.Offset(y, 2) = "Series.Name=" & ppSeries.Name
単純に、ppSeries.Nameで系列の名前を取得しています
17:51 2.3.3 Series.XValuesを表示
'グラフの種類によって、どっちを先にする？キレイな表を作りたかったり。
Dim boxXValues As Variant
boxXValues = ppSeries.XValues
↑Variantt型の変数に↑単純に代入、代入後、UBound(boxXValues)で個数分ループを回す
For x = 1 To UBound(boxXValues)
rBASE.Offset(y, 2 + x) = boxXValues(x)
Next
19:02 2.3.4 Series.Valuesを表示
同様に、
Dim boxValues As Variant boxValues = ppSeries.Values ↑Variantt型の変数に↑単純に代入、代入後、UBound(boxValues)で個数分ループを回す For x = 1 To UBound(boxValues) rBASE.Offset(y, 2 + x) = boxValues(x) Next
20:28 2.3.5 ソースコード全体
系列を二つ作成して、テストをしました。
組合せた結果:
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
24:24 2.4 急に脱線して出力結果の仕様変更を行う
突然、客先で修正を始める、迷惑プログラマーの姿・・・※反省しないとなぁ・・・
説明が飛んでしまい、迷惑をかけます
https://www.youtube.com/watch?v=RD5ovhJncsY&t=1464
↑突然コードを修正するオッサンの姿・・・
28:06 2.4.1 系列が入れ替わっている場合
n=1 一番目の系列判断を入れて、
凡例 XValueの表示を一行目だけにして、
値 Valueはそのままに、突然コードを変更してテスト
33:21 3.問題点・改善点
3.1 Series.Values Series.XValues の表示順や同じ値は一つにしたい
そのまま、単純に表示しているが、
目的が表、値の復活なら、
表の形で出力したい、
※現在の系列別だと、重複してて、見にくいし・使いにくい
33:54 3.2 正規のリンク貼り付け？に対応していない 貼付け手順によってタイプが違う
Excelグラフの貼り方、形式によって
オブジェクト、グラフシェイプのTypeが違う事を操作説明する
35:21 単純な、手順 ショートカットで何も考えないで貼り付ける
①Excelでグラフ選択後、Ctrl+C
②PowerPointで貼り付け Ctrl+V
で作られたグラフは、シェイプのType=3で、
36:04 形式を選択して貼付で選ぶ 貼付けパターンが三種類テストしてみます
①Excelでグラフ選択後、Ctrl+C
②PowerPointで形式を選択して貼り付け
ア.Excelグラフオブジェクト Type=7
イ.○リンクを選択して Excelグラフオブジェクト Type=10
ウ.Officeグラフィックオブジェクト Type=3
38:53 元Excelの値を変更して再テスト
現在のコードはOLE型のExcelグラフオブジェクトに対応していない、
グラフの値を取得できません。
OLEオブジェクト型で貼られたグラフを探るには？※リンク切れた場合、探れるのか？
を探らないとマズイと問題点に気が付く・・・
42:01 グラフのタイプ Shape.Type を説明する
Shape.Type プロパティ (PowerPoint)
https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.shape.type
から
MsoShapeType 列挙 (Office)
https://learn.microsoft.com/ja-jp/office/vba/api/office.msoshapetype
msoChart 3 グラフ
msoEmbeddedOLEObject 7 埋め込み OLE オブジェクト
msoLinkedOLEObject 10 リンク OLE オブジェクト
7と10の場合を探らないと、
質問者様が使っている貼り付け方法を聞かないと・・・
46:04 4.終わりの挨拶
んっ？
積み残しのshape Type 7,10のOLE型が本命なのかも・・・
質問者さんに期待を持たせて、悪いことしたかも・・・
こんな感じで、テストコードを書いてみました。
アレンジして使ってみてください。
パワーポイント リンク切れグラフの値を取り出す PowerPoint マクロ VBA
https://www.youtube.com/playlist?list=PL8vZhsyiiFhuAVnLl4S9tWujchW7rqOUm
再生リスト↑貼り付けたExcelグラフがリンク切れ 値を救いたい 吸い出したい
動画内で修正したコード:
パワポのグラフから値を取り出すソースコード:
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グラフがリンク切れ 値を救いたい 吸い出したい
