Excelの値でPowerPointの文字を一括検索置換するマクロ

PowerPointで大量の文字列を検索置換したい時に、超時短になるマクロをご紹介します。Excelに入力したセルの値をPowerPointに読み込んで、全スライドの文字列を一括で検索置換します。

例えば、日本語を英語に翻訳する作業が発生し、翻訳データがあった場合、英語を一文ずつテキストボックスにコピペ入力していくのは、テキスト量によっては大変時間がかかり、入力ミスで誤字脱字が発生する可能性も考えられます。

そんな時に、マクロで文字列の一括検索置換をして一気に流し込めば、永遠とコピペせずとも一瞬で置換が完了します。

Excelで検索置換データを作成する
Excelのライブラリーを追加する
一括検索置換するマクロ
1. コード
2. 実行結果

Excelで検索置換データを作成する

Excelを開き、A列に「検索する文字列」、B列に「置換後の文字列」を入力します。上の行から順に置換していくのですが、この並び順では「オレンジ」が置換されると「オレンジジュース」が「Orangeジュース」と置換されてしまうので、A列を文字数が多い順に並び替えます。

セル「C2」にLEN関数で「=LEN(A2)」と入力して文字数をカウントする列を作ります。セル「C2」以下は、「C2」の右下にある「フィルハンドル」をダブルクリックして「オートフィル機能」で連続データ入力しましょう。

文字数が入力できたら、C列を降順に並び替えます。

ファイル名を「text.xlsx」で保存して完了です。

Excelのライブラリーを追加する

作成したExcelファイルの読み込みができるように機能拡張をします。

「開発」タブ →「コード」グループ →「Visual Basic」→「Microsoft Visual Basic for Applications」を立ち上げ、「ツール」→「参照設定」をクリックします。

「参照設定」ダイアログが開くので、「Microsoft Excel 16.0 Object Library」にチェックを入れます。

バージョンによりファイル名は異なります。

準備が整ったので、マクロを実行しましょう。

一括検索置換するマクロ

コード

Sub 一括検索置換()

    Dim XL As New Excel.Application
    Dim XLBK As Excel.Workbook
    Dim kensaku As Excel.Range
    Dim okikae As Excel.Range
    Dim i As Long
    Dim sld As Slide
    Dim shp As Shape
    Dim txtRng As TextRange
    Dim tmpRng As TextRange

    'Excelを読込
    Set XLBK = XL.Workbooks.Open("テキストファイルまでのパス\text.xlsx")
    '検索ワード
    Set kensaku = XLBK.Worksheets("Sheet1").Range("A1")
    '置換ワード
    Set okikae = XLBK.Worksheets("Sheet1").Range("B1")
    
    With ActivePresentation
    
        Do While True
        
            'セルが空白になったら終了
            If kensaku.Value = "" Then Exit Do

            '全スライドに処理を繰り返す
            For i = 1 To .Slides.Count
        
                Set sld = Application.ActivePresentation.Slides(i)
     
                For Each shp In sld.Shapes
                
                    If shp.Type = msoTextBox Or shp.Type = msoAutoShape Then

                        Set txtRng = shp.TextFrame.TextRange
                    
                        '検索置換
                        Set tmpRng = txtRng.Replace( _
                        FindWhat:=kensaku, _
                        Replacewhat:=okikae, _
                        WholeWords:=False)
    
                        Do While Not tmpRng Is Nothing
                        
                            Set txtRng = txtRng.Characters( _
                            tmpRng.Start + tmpRng.Length, txtRng.Length)
    
                            Set tmpRng = txtRng.Replace( _
                            FindWhat:=kensaku, _
                            Replacewhat:=okikae, _
                            WholeWords:=False)
                            
                        Loop
                    End If
                Next shp
            Next i
                 
            '1つ下のセルに移動
            Set kensaku = kensaku.Offset(1, 0)
            Set okikae = okikae.Offset(1, 0)

        Loop
    End With
    
XL.Quit

End Sub

Set XLBK = XL.Workbooks.Open(“テキストファイルまでのパス\text.xlsx”)に、作成した「text.xlsx」ファイルのプロパティを参照し、テキストファイルまでのパスを入力してください。