パワーポイントの一括置換：複数の単語をエクセルリストから読み込む

質問

はじめまして、トフィーです。

色々と皆様の置換方法や、パワーポイントの操作、エクセルの操作を参考にしてパワーポイントの一括置換プログラムを作成しようとしていますが、
下記のコードですと、一括置換が出来ますが10単語を一括置換するだけで約10分掛かります。
何か、もっと早く置換が出来るプログラミングは出来ないのでしょうか？
(エクセルのマクロから書きました。）
宜しくお願い致します。

Private Sub run_click()

translate '下記のコードから置換
End Sub

Private Sub translate()
c = 0
myFLD = loc.Text

' 複数のパワーポイントを同じフォルダーで探し、一つずつ開きます
Set myApp = CreateObject("PowerPoint.Application")
myApp.Visible = True
With myApp.FileSearch
.LookIn = myFLD
.FileName = "*.ppt"
If .Execute > 0 Then
For Each myF In .FoundFiles
With myApp.Presentations.Open(myF)

'エクセルから単語読み込み 列１の単語を列２の単語で置換
On Error Resume Next
For c = 0 To 10
myWD1 = Range("B" & c + 3)

myWD2 = Range("C" & c + 3)

'置換開始
For Each myS In myApp.ActivePresentation.Slides
For Each mySP In myS.Shapes
mySP.TextFrame.TextRange _
= Replace(mySP.TextFrame.TextRange, myWD1, myWD2)
Next
Next

Next c

.Save
.Close
'パワーポイントを閉じる

End With
Next
End If
End With
myApp.Quit
Set myApp = Nothing
MsgBox "END"

End Sub

回答No.1

n_na_tto

時間がかかるのは同じかとは思いますが、こんな方法も。

Dim myArr As Variant
Sub Chikann()
Dim myApp As Object 'PowerPoint.Application
Dim myS As Object 'PowerPoint.Slide
Dim mySP As Object 'PowerPoint.Shape
Dim i As Long
myFLD = Loc.Text
'検索パターンB列,C列から配列に代入
myArr = Range("B3:C13")
Set myApp = CreateObject("PowerPoint.Application")
myApp.Visible = True
With myApp.FileSearch
　.LookIn = myFLD
　.Filename = "*.ppt"
　.Execute
　For i = 1 To .FoundFiles.Count
　　With myApp.Presentations.Open(.FoundFiles(i))
　　　For Each myS In .Slides
　　　　For Each mySP In myS.Shapes
　　　　　With mySP
　　　　　　If .HasTextFrame Then
　　　　　　　If .TextFrame.TextRange.Text <> "" Then
　　　　　　　　Hennkann .TextFrame.TextRange
　　　　　　　End If
　　　　　　End If
　　　　　End With
　　　　Next
　　　Next
　　　.Save
　　　.Close
　　End With
　Next i
End With
myApp.Quit
Set myApp = Nothing
MsgBox "END"
End Sub
Sub Hennkann(txtRng As Object) 'PowerPoint.TextRange
Dim allRng As Object 'PowerPoint.TextRange
Dim tmpRng As Object 'PowerPoint.TextRange
Dim i As Long
'渡されたTextRangeの中から検索置換
For i = 1 To UBound(myArr, 1)
　Set allRng = txtRng
　Set tmpRng = allRng.Replace(FindWhat:=myArr(i, 1), _
　　　Replacewhat:=myArr(i, 2), WholeWords:=True)
　Do While Not tmpRng Is Nothing
　　Set allRng = allRng.Characters(tmpRng.Start + tmpRng.Length, _
　　　　allRng.Length)
　　Set tmpRng = allRng.Replace(FindWhat:=myArr(i, 1), _
　　　　Replacewhat:=myArr(i, 2), WholeWords:=True)
　Loop
Next i
End Sub

お礼

n_na_ttoさん

ご親切な回答
大変どうもありがとうございます。
早速参考にして作成してみます。