パワーポイントの置き換えマクロ

質問

パワーポイントのたくさんの単語の文字の置き換えをしたく、自動のマクロ機能で記録したのですが、何度やってもＶＢＡになりません。
どうやったらいいのでしょうか？
同じ用途のマクロをエクセルで作ったのですが、こちらをうまく利用できますか？

業務でいろいろな資料を翻訳ソフトを使って、他国語に翻訳しています。
すべてがうまく翻訳されるわけではなく、辞書登録してもいくつかの単語は毎回同じ言葉に訳されてしまうので、現在は、手作業で置き換え作業しています。
工数がかかってしまうので、マクロ機能で一括置き換えがしたいのです。
よろしくお願いします。

回答No.3

n_na_tto · ベストアンサー

そこからですか。では、もう一度修正コードを全部。
●Excelのワークシートに 置換前　置換後 を下のように並べておいて
　　　A　　 B
1　原油　石油
2　空白　　白
3　生命　生活

●ExcelでAlt+F11→挿入→標準モジュールに以下を貼り付け

Dim myArr As Variant
Dim VBReg As Object
Dim Matches As Object
Sub Chikann2()
Dim cntRow As Long
Dim myRng As Range
Dim objPPT As Object 'PowerPoint.Application
Dim myPre As Object 'PowerPoint.Presentation
Dim Sld As Object 'PowerPoint.Slide
Dim Shp As Object 'PowerPoint.Shape
Dim myRow As Object 'PowerPoint.Row
Dim myCell As Object 'PowerPoint.Cell
Dim iShp As Object 'PowerPoint.Shape
'A,B列の置換パターン配列に
　cntRow = Range("A" & Rows.Count).End(xlUp).Row
　Set myRng = Range("A1:B" & cntRow)
　myArr = myRng.Value
'パワポ起動
　On Error GoTo Mikidou
　Set objPPT = GetObject(, "PowerPoint.Application")
　With objPPT
　　.Activate
　　Set myPre = .ActivePresentation
　End With
　On Error GoTo 0
　Set VBReg = CreateObject("VBScript.RegExp")
'図形ループ
　For Each Sld In myPre.Slides
　　For Each Shp In Sld.Shapes
　　　With Shp
　　　　' 普通のオブジェクトの場合
　　　　If .HasTextFrame Then
　　　　　Hennkann .TextFrame.TextRange
　　　　' 表の場合
　　　　ElseIf .HasTable Then
　　　　　For Each myRow In .Table.Rows
　　　　　　For Each myCell In myRow.Cells
　　　　　　　Hennkann myCell.Shape.TextFrame.TextRange
　　　　　　Next
　　　　　Next
　　　　' グループオブジェクトの場合
　　　　ElseIf .Type = msoGroup Then
　　　　　For Each iShp In .GroupItems
　　　　　　With iShp
　　　　　　　If .HasTextFrame Then
　　　　　　　　Hennkann .TextFrame.TextRange
　　　　　　　End If
　　　　　　End With
　　　　　Next
　　　　End If
　　　End With
　　Next
　Next
Set iShp = Nothing
Set myCell = Nothing
Set myRow = Nothing
Set Shp = Nothing
Set Sld = Nothing
Set myPre = Nothing
Set objPPT = Nothing
Set Matches = Nothing
Set VBReg = Nothing
Exit Sub
Mikidou:　MsgBox "パワポファイル開いといて"
End Sub
Sub Hennkann(txtRng As Object) 'PowerPoint.TextRange
Dim i As Long
Dim m As Integer
Dim j As Integer
Dim txtRng2 As Object 'PowerPoint.TextRange
　If txtRng.Text <> "" Then
　　'渡されたTextRangeの中から検索置換
　　For i = 1 To UBound(myArr, 1)
　　　If Len(myArr(i, 1)) > 0 Then
　　　　With VBReg
　　　　　.Pattern = myArr(i, 1)
　　　　　.IgnoreCase = False
　　　　　.Global = True
　　　　　If .test(txtRng.Text) Then
　　　　　　For m = 1 To txtRng.Paragraphs.Count
　　　　　　　Set txtRng2 = txtRng.Paragraphs(m)
　　　　　　　If .test(txtRng2.Text) Then
　　　　　　　　Set Matches = .Execute(txtRng2.Text)
　　　　　　　　For j = Matches.Count - 1 To 0 Step -1
　　　　　　　　　With Matches(j)
　　　　　　　　　　With txtRng2.Characters(.FirstIndex + 1, .Length)
　　　　　　　　　　　.Text = VBReg.Replace(.Text, myArr(i, 2))
　　　　　　　　　　End With
　　　　　　　　　End With
　　　　　　　　Next j
　　　　　　　End If
　　　　　　Next m
　　　　　End If
　　　　End With
　　　End If
　　Next i
　End If
End Sub

お礼

すみません、そんなレベルなんです…。
回答本当にありがとうございました！
貼り付けてみたらできて、涙ものの大感動でしたっ!!
エクセルの置き換えマクロも手入力の置き換えを
自動で記録したレベルなんです。
まだまだ、お聞きしたいことがあるのですが、よかったら回答をお願いできないでしょうか？
ＡとＢ行に置き換えたい文字を入れたデータファイルは作りました。
しかし、そのファイルには３枚シートがあり、そのうちの１枚が文字データ表になります。
そのシートを指定することはできますでしょうか？
また、同シートを使って、エクセルで他のエクセルファイル内を
一括で置き換えるＶＢＡもあるのでしょうか？
さらに、同様にそのエクセル置き換えデータを使用した
ワードのファイルも一括で置き換えはできるのでしょうか？
現在、ワードも手入力で置き換えしたものを自動で記録したマクロを使用しています。
たくさんの質問で申し訳ありません。
ぜひともよろしくお願いします。

回答No.4

n_na_tto

●シートを指定するのは簡単です。
例えばシート名を指定する場合、以下のように変更します。

[変更前]
　cntRow = Range("A" & Rows.Count).End(xlUp).Row
　Set myRng = Range("A1:B" & cntRow)
↓
[変更後]
　With Worksheets("Sheet1") 'シート名がSheet1の場合
　　cntRow = .Range("A" & Rows.Count).End(xlUp).Row
　　Set myRng = .Range("A1:B" & cntRow)
　End With

●Excelの置換のコードは、各文字のフォントを気にする必要が
ないので相当短くなります。
このサイトで別スレを立ててください。その場合は
必ず具体的に質問してください。

●Wordの置換のコードの研究は、このサイトではないほうが
いいような気がします。
ここのシステムはどうもコードを連続してアップしたりするのが
面倒なんです。

お礼

再回答いただきありがとうございます！
早速明日やってみます。
エクセルやワードの件もありがとうございます。
コードを教えてくれるようなサイトもあるのですね。
知りませんでした！

回答No.2

n_na_tto

Sub Hennkannの中の１行を訂正します。
参照設定不要にしたつもりだったのに..

誤
Dim txtRng2 As TextRange
↓
正
Dim txtRng2 As Object 'PowerPoint.TextRange
でお願いします。

回答No.1

n_na_tto

Excel VBAから、現在開いているPowerPointファイルの置換を行う例です。

●ExcelのA列に置換前、B列に置換後
[正規表現を使っていますので、正規表現のワイルドカードも
使用可能です。検索で調べてください。]

　　　A　　 B
1　原油　石油
2　空白　　白
3　生命　生活

●Excel VBAで

Dim myArr As Variant
Dim VBReg As Object
Dim Matches As Object
Sub Chikann2()
Dim cntRow As Long
Dim myRng As Range
Dim objPPT As Object 'PowerPoint.Application
Dim myPre As Object 'PowerPoint.Presentation
Dim Sld As Object 'PowerPoint.Slide
Dim Shp As Object 'PowerPoint.Shape
Dim myRow As Object 'PowerPoint.Row
Dim myCell As Object 'PowerPoint.Cell
Dim iShp As Object 'PowerPoint.Shape
'A,B列の置換パターン配列に
　cntRow = Range("A" & Rows.Count).End(xlUp).Row
　Set myRng = Range("A1:B" & cntRow)
　myArr = myRng.Value
'パワポ起動
　On Error GoTo Mikidou
　Set objPPT = GetObject(, "PowerPoint.Application")
　With objPPT
　　.Activate
　　Set myPre = .ActivePresentation
　End With
　On Error GoTo 0
　Set VBReg = CreateObject("VBScript.RegExp")
'図形ループ
　For Each Sld In myPre.Slides
　　For Each Shp In Sld.Shapes
　　　With Shp
　　　　' 普通のオブジェクトの場合
　　　　If .HasTextFrame Then
　　　　　Hennkann .TextFrame.TextRange
　　　　' 表の場合
　　　　ElseIf .HasTable Then
　　　　　For Each myRow In .Table.Rows
　　　　　　For Each myCell In myRow.Cells
　　　　　　　Hennkann myCell.Shape.TextFrame.TextRange
　　　　　　Next
　　　　　Next
　　　　' グループオブジェクトの場合
　　　　ElseIf .Type = msoGroup Then
　　　　　For Each iShp In .GroupItems
　　　　　　With iShp
　　　　　　　If .HasTextFrame Then
　　　　　　　　Hennkann .TextFrame.TextRange
　　　　　　　End If
　　　　　　End With
　　　　　Next
　　　　End If
　　　End With
　　Next
　Next
Set iShp = Nothing
Set myCell = Nothing
Set myRow = Nothing
Set Shp = Nothing
Set Sld = Nothing
Set myPre = Nothing
Set objPPT = Nothing
Set Matches = Nothing
Set VBReg = Nothing
Exit Sub
Mikidou:　MsgBox "パワポファイル開いといて"
End Sub
Sub Hennkann(txtRng As Object) 'PowerPoint.TextRange
Dim i As Long
Dim m As Integer
Dim j As Integer
Dim txtRng2 As TextRange
　If txtRng.Text <> "" Then
　　'渡されたTextRangeの中から検索置換
　　For i = 1 To UBound(myArr, 1)
　　　If Len(myArr(i, 1)) > 0 Then
　　　　With VBReg
　　　　　.Pattern = myArr(i, 1)
　　　　　.IgnoreCase = False
　　　　　.Global = True
　　　　　If .test(txtRng.Text) Then
　　　　　　For m = 1 To txtRng.Paragraphs.Count
　　　　　　　Set txtRng2 = txtRng.Paragraphs(m)
　　　　　　　If .test(txtRng2.Text) Then
　　　　　　　　Set Matches = .Execute(txtRng2.Text)
　　　　　　　　For j = Matches.Count - 1 To 0 Step -1
　　　　　　　　　With Matches(j)
　　　　　　　　　　With txtRng2.Characters(.FirstIndex + 1, _
　　　　　　　　　　　.Length)
　　　　　　　　　　　.Text = myArr(i, 2)
　　　　　　　　　　End With
　　　　　　　　　End With
　　　　　　　　Next j
　　　　　　　End If
　　　　　　Next m
　　　　　End If
　　　　End With
　　　End If
　　Next i
　End If
End Sub

お礼

回答ありがとうございます。
早速、試してみます。
この言語を、日本語部分も含めて、全部貼り付けたらマクロが動くということでしょうか？