プロが教える店舗&オフィスのセキュリティ対策術

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

色々と皆様の置換方法や、パワーポイントの操作、エクセルの操作を参考にしてパワーポイントの一括置換プログラムを作成しようとしていますが、
下記のコードですと、一括置換が出来ますが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)

'エクセルから単語読み込み 列1の単語を列2の単語で置換
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

「パワーポイントの一括置換:複数の単語をエ」の質問画像

A 回答 (1件)

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



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
    • good
    • 0
この回答へのお礼

n_na_ttoさん

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

お礼日時:2008/12/05 23:14

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!