Go to Qiita Advent Calendar Top
LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@Ko813(葉坪 忍田)

【PowerPoint VBA】スライドの色を一括置換＆抽出するマクロ（コピペで使える！）

Posted at

PowerPointで作成した資料のデザイン変更。「テーマカラーの赤を、全部青に変えたい…」なんて時に、一つずつ図形の色を変えていくのはとても大変ですよね。

この記事では、そんな面倒な作業を自動化するVBAマクロを2つ紹介します。

  1. スライド内の指定した色を、別の色に一括置換するマクロ
  2. スライド内で使われている色を一覧にして、Excelに抽出するマクロ

コピペしてすぐに使えるので、ぜひ活用してください！

🚀 できること

  • 色の一括置換: 「この赤色（R:255, G:0, B:0）を、全部この青色（R:0, G:0, B:255）にして！」という指示を一度で完了できます。図形の塗りつぶし、枠線、テキスト、表のセルなど、あらゆる箇所の色が対象です。
  • 使用色の棚卸し: 「この資料、全部で何色使ってるんだろう？」という時に、使用されている色をExcelに一覧で出力します。色見本とRGB値がわかるので、デザインの統一や色コードの確認に便利です。

📖 使い方

準備

  1. 開発タブの表示:
    PowerPointの ファイル > オプション > リボンのユーザー設定 を開き、右側のリストにある 開発 にチェックを入れてOKを押します。

  2. VBAエディタを開く:
    開発 タブをクリックし、Visual Basic をクリックします (または Alt + F11 キー)。

  3. モジュールの挿入:
    VBAエディタの左側にあるプロジェクトエクスプローラーから、お使いのファイル名 (VBAProject(...)) を右クリックし、挿入 > 標準モジュール を選択します。

  4. コードの貼り付け:
    後述するコードを、作成した標準モジュールに貼り付けます。機能ごとに2つのモジュールに分けることをお勧めします。

    • Module1 に「色置換機能」のコード
    • Module2 に「色抽出機能」のコード

  5. 参照設定 (重要！):
    VBAエディタの ツール メニューから 参照設定 をクリックします。一覧の中から Microsoft Scripting Runtime を探し、チェックを入れて OK を押してください。（これがないと色抽出マクロがエラーになります）

マクロの実行

  1. PowerPointの 開発 タブ > マクロ をクリックします。
  2. 実行したいマクロを選択して 実行 ボタンを押します。
    • メイン_色の一括置換: 色を置換する場合
    • メイン_使用色をExcel抽出: 色の一覧をExcelに出力する場合

📝 コード全体

モジュール1：色置換機能 (Module_ColorChanger)

'================================================================================
' Module: Module_ColorChanger
' 機能：プレゼンテーション内の指定した色を一括で置換する
'================================================================================

'================================================================================
' メイン処理：プレゼンテーション内の指定した色を別の色に一括置換する
'================================================================================
Public Sub メイン_色の一括置換()
    '--- 変数の宣言 ---
    Dim str_置換前の色入力 As String
    Dim str_置換後の色入力 As String
    Dim lng_置換前の色RGB As Long
    Dim lng_置換後の色RGB As Long
    Dim obj_スライド As Slide
    Dim obj_図形 As Shape
    Dim lng_変更カウント As Long
    Dim arr_置換前の色配列() As String
    Dim arr_置換後の色配列() As String

    '--- 初期化 ---
    lng_変更カウント = 0

    '--- 色の指定 ---
    str_置換前の色入力 = InputBox("【手順1/2】置換したい元の色をRGB形式で入力してください。" & vbCrLf & "例: 255,0,0 (赤色)", "元の色を指定")
    If str_置換前の色入力 = "" Then Exit Sub

    str_置換後の色入力 = InputBox("【手順2/2】新しく設定する色をRGB形式で入力してください。" & vbCrLf & "例: 0,0,255 (青色)", "新しい色を指定")
    If str_置換後の色入力 = "" Then Exit Sub

    '--- 入力値の変換とエラーチェック ---
    On Error GoTo InvalidInput
    arr_置換前の色配列 = Split(str_置換前の色入力, ",")
    arr_置換後の色配列 = Split(str_置換後の色入力, ",")
    lng_置換前の色RGB = RGB(Trim(arr_置換前の色配列(0)), Trim(arr_置換前の色配列(1)), Trim(arr_置換前の色配列(2)))
    lng_置換後の色RGB = RGB(Trim(arr_置換後の色配列(0)), Trim(arr_置換後の色配列(1)), Trim(arr_置換後の色配列(2)))
    On Error GoTo 0

    '--- 置換処理の開始 ---
    Application.ScreenUpdating = False
    For Each obj_スライド In ActivePresentation.Slides
        For Each obj_図形 In obj_スライド.Shapes
            Call run_図形の色置換(obj_図形, lng_置換前の色RGB, lng_置換後の色RGB, lng_変更カウント)
        Next obj_図形
    Next obj_スライド
    Application.ScreenUpdating = True

    '--- 結果の表示 ---
    MsgBox lng_変更カウント & " 箇所の色を変更しました。", vbInformation, "処理完了"
    Exit Sub

'--- エラーハンドラ ---
InvalidInput:
    MsgBox "RGB値の入力形式が正しくありません。" & vbCrLf & "カンマ区切りの数値を入力してください（例: 255,0,0）。", vbExclamation, "入力エラー"
End Sub

'================================================================================
' 実行操作：図形の色を再帰的に置換する
'================================================================================
Private Sub run_図形の色置換(ByVal obj_対象図形 As Shape, ByVal lng_置換前の色 As Long, ByVal lng_置換後の色 As Long, ByRef lng_変更カウント As Long)
    On Error Resume Next
    
    Dim obj_子図形 As Shape
    Dim lng_行 As Long
    Dim lng_列 As Long

    '--- グループ化された図形の場合、中の各図形に対して再帰的に処理 ---
    If obj_対象図形.Type = msoGroup Then
        For Each obj_子図形 In obj_対象図形.GroupItems
            Call run_図形の色置換(obj_子図形, lng_置換前の色, lng_置換後の色, lng_変更カウント)
        Next obj_子図形
    End If

    '--- 図形の塗りつぶし ---
    If obj_対象図形.Fill.Visible = msoTrue And obj_対象図形.Fill.Type = msoFillSolid Then
        If obj_対象図形.Fill.ForeColor.RGB = lng_置換前の色 Then
            obj_対象図形.Fill.ForeColor.RGB = lng_置換後の色
            lng_変更カウント = lng_変更カウント + 1
        End If
    End If

    '--- 図形の線 ---
    If obj_対象図形.Line.Visible = msoTrue Then
        If obj_対象図形.Line.ForeColor.RGB = lng_置換前の色 Then
            obj_対象図形.Line.ForeColor.RGB = lng_置換後の色
            lng_変更カウント = lng_変更カウント + 1
        End If
    End If

    '--- テキストの色 (TextFrame / TextFrame2) ---
    If obj_対象図形.HasTextFrame Then
        If obj_対象図形.TextFrame.HasText Then
            If obj_対象図形.TextFrame.TextRange.Font.Color.RGB = lng_置換前の色 Then
                obj_対象図形.TextFrame.TextRange.Font.Color.RGB = lng_置換後の色
                lng_変更カウント = lng_変更カウント + 1
            End If
        End If
        If obj_対象図形.TextFrame2.HasText Then
             If obj_対象図形.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = lng_置換前の色 Then
                obj_対象図形.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = lng_置換後の色
                lng_変更カウント = lng_変更カウント + 1
            End If
        End If
    End If

    '--- 表内のセルの背景色 ---
    If obj_対象図形.HasTable Then
        For lng_行 = 1 To obj_対象図形.Table.Rows.count
            For lng_列 = 1 To obj_対象図形.Table.Columns.count
                With obj_対象図形.Table.Cell(lng_行, lng_列).Shape
                    If .Fill.Visible = msoTrue And .Fill.Type = msoFillSolid Then
                        If .Fill.ForeColor.RGB = lng_置換前の色 Then
                            .Fill.ForeColor.RGB = lng_置換後の色
                            lng_変更カウント = lng_変更カウント + 1
                        End If
                    End If
                End With
            Next lng_列
        Next lng_行
    End If
    
    On Error GoTo 0
End Sub

モジュール2：色抽出機能 (Module_ColorExtractor)

'================================================================================
' Module: Module_ColorExtractor
' 機能：プレゼンテーション内で使用されている色をExcelに一覧で出力する
'================================================================================

'================================================================================
' メイン処理：プレゼンテーション内で使用されている色をExcelに一覧で出力する
'================================================================================
Public Sub メイン_使用色をExcel抽出()
    '--- 変数の宣言 ---
    Dim dic_色一覧 As Object
    Dim obj_スライド As Slide
    Dim obj_図形 As Shape
    Dim var_キー As Variant
    Dim obj_Excelアプリ As Object
    Dim wb_ブック As Object
    Dim ws_シート As Object
    Dim lng_行番号 As Long
    
    '--- Dictionaryオブジェクトを作成 ---
    Set dic_色一覧 = CreateObject("Scripting.Dictionary")
    
    '--- 色の抽出 ---
    For Each obj_スライド In ActivePresentation.Slides
        For Each obj_図形 In obj_スライド.Shapes
            Call run_図形の色収集(obj_図形, dic_色一覧)
        Next obj_図形
    Next obj_スライド
    
    If dic_色一覧.count = 0 Then
        MsgBox "プレゼンテーション内に単色のオブジェクトが見つかりませんでした。", vbInformation, "情報"
        Exit Sub
    End If
    
    '--- Excelへの出力 ---
    On Error Resume Next
    Set obj_Excelアプリ = GetObject(, "Excel.Application")
    If obj_Excelアプリ Is Nothing Then
        Set obj_Excelアプリ = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    obj_Excelアプリ.Visible = True
    Set wb_ブック = obj_Excelアプリ.Workbooks.Add
    Set ws_シート = wb_ブック.Sheets(1)
    
    '--- ヘッダーと書式を設定 ---
    ws_シート.Cells(1, 1).Value = "色見本"
    ws_シート.Cells(1, 2).Value = "RGB値"
    ws_シート.Range("A1:B1").Font.Bold = True
    ws_シート.Columns("B").NumberFormat = "@"

    '--- Dictionaryから色を取り出してExcelに出力 ---
    lng_行番号 = 2
    For Each var_キー In dic_色一覧.Keys
        ws_シート.Cells(lng_行番号, 1).Interior.Color = var_キー
        ws_シート.Cells(lng_行番号, 2).Value = dic_色一覧(var_キー)
        lng_行番号 = lng_行番号 + 1
    Next var_キー
    
    '--- 列幅を自動調整 ---
    ws_シート.Columns("A:B").AutoFit
    ws_シート.Columns("A").ColumnWidth = 10
    
    '--- 後処理 ---
    Set ws_シート = Nothing
    Set wb_ブック = Nothing
    Set obj_Excelアプリ = Nothing
    Set dic_色一覧 = Nothing
    
    MsgBox "使用されている色の抽出が完了し、Excelに出力しました。", vbInformation, "処理完了"
End Sub

'================================================================================
' 実行操作：図形から再帰的に色を収集する
'================================================================================
Private Sub run_図形の色収集(ByVal obj_対象図形 As Shape, ByRef dic_色一覧 As Object)
    On Error Resume Next
    
    Dim obj_子図形 As Shape
    Dim lng_行 As Long
    Dim lng_列 As Long
    Dim lng_色RGB As Long
    Dim str_色RGB文字列 As String

    '--- グループ化された図形 ---
    If obj_対象図形.Type = msoGroup Then
        For Each obj_子図形 In obj_対象図形.GroupItems
            Call run_図形の色収集(obj_子図形, dic_色一覧)
        Next obj_子図形
    End If

    '--- 図形の塗りつぶし ---
    If obj_対象図形.Fill.Visible = msoTrue And obj_対象図形.Fill.Type = msoFillSolid Then
        lng_色RGB = obj_対象図形.Fill.ForeColor.RGB
        If Not dic_色一覧.Exists(lng_色RGB) Then
            str_色RGB文字列 = (lng_色RGB Mod 256) & "," & ((lng_色RGB \ 256) Mod 256) & "," & (lng_色RGB \ 65536)
            dic_色一覧.Add lng_色RGB, str_色RGB文字列
        End If
    End If

    '--- 図形の線 ---
    If obj_対象図形.Line.Visible = msoTrue Then
        lng_色RGB = obj_対象図形.Line.ForeColor.RGB
        If Not dic_色一覧.Exists(lng_色RGB) Then
            str_色RGB文字列 = (lng_色RGB Mod 256) & "," & ((lng_色RGB \ 256) Mod 256) & "," & (lng_色RGB \ 65536)
            dic_色一覧.Add lng_色RGB, str_色RGB文字列
        End If
    End If

    '--- テキストの色 (TextFrame / TextFrame2) ---
    If obj_対象図形.HasTextFrame Then
        If obj_対象図形.TextFrame.HasText Then
            lng_色RGB = obj_対象図形.TextFrame.TextRange.Font.Color.RGB
            If Not dic_色一覧.Exists(lng_色RGB) Then
                str_色RGB文字列 = (lng_色RGB Mod 256) & "," & ((lng_色RGB \ 256) Mod 256) & "," & (lng_色RGB \ 65536)
                dic_色一覧.Add lng_色RGB, str_色RGB文字列
            End If
        End If
        If obj_対象図形.TextFrame2.HasText Then
            If obj_対象図形.TextFrame2.TextRange.Font.Fill.Type = msoFillSolid Then
                 lng_色RGB = obj_対象図形.TextFrame2.TextRange.Font.Fill.ForeColor.RGB
                 If Not dic_色一覧.Exists(lng_色RGB) Then
                    str_色RGB文字列 = (lng_色RGB Mod 256) & "," & ((lng_色RGB \ 256) Mod 256) & "," & (lng_色RGB \ 65536)
                    dic_色一覧.Add lng_色RGB, str_色RGB文字列
                End If
            End If
        End If
    End If
    
    '--- 表内のセルの背景色 ---
    If obj_対象図形.HasTable Then
        For lng_行 = 1 To obj_対象図形.Table.Rows.count
            For lng_列 = 1 To obj_対象図形.Table.Columns.count
                With obj_対象図形.Table.Cell(lng_行, lng_列).Shape
                    If .Fill.Visible = msoTrue And .Fill.Type = msoFillSolid Then
                        lng_色RGB = .Fill.ForeColor.RGB
                        If Not dic_色一覧.Exists(lng_色RGB) Then
                            str_色RGB文字列 = (lng_色RGB Mod 256) & "," & ((lng_色RGB \ 256) Mod 256) & "," & (lng_色RGB \ 65536)
                            dic_色一覧.Add lng_色RGB, str_色RGB文字列
                        End If
                    End If
                End With
            Next lng_列
        Next lng_行
    End If

    On Error GoTo 0
End Sub

💡 コードのポイント

  • 再帰処理: run_図形の色置換 や run_図形の色収集 といった関数は、グループ化された図形の中の図形に対しても同じ処理を繰り返す「再帰処理」というテクニックを使っています。これにより、どんなに複雑にグループ化されていても、すべての図形を漏らさずチェックできます。
  • エラーハンドリング: On Error Resume Next を使うことで、SmartArtやグラフなど、このマクロでは色を取得・変更できない特殊なオブジェクトがあってもエラーで止まることなく、最後まで処理を完走させます。
  • Dictionaryオブジェクト: 色を抽出する際に Scripting.Dictionary を使っています。これは、同じ色の情報を重複して登録しない特性があるため、ユニークな色だけを効率よく集めるのに最適です。

🎉 おわりに

PowerPointでの手作業をVBAで自動化すると、作業時間が劇的に短縮できます。
ぜひこのマクロをベースに、ご自身の業務に合わせてカスタマイズしてみてください！

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?