Sub DividePptByWord() ' パワポの各シートに特定の語句があるかどうかで、 ' 2つのファイルに振り分ける。 Dim fs1 As Scripting.FileSystemObject 'ファイルシステム関係 Dim ppaAppli As New PowerPoint.Application Dim pppPresenAll As PowerPoint.Presentation Dim pppPresenMost As PowerPoint.Presentation Dim pppPresenAnswer As PowerPoint.Presentation Dim strPath1 As String Dim strPathAll As String, strPathMost As String, strPathAnswer As String Dim strFind As String, strFind2 As String Dim strText As String Dim intSlide As Integer, intNumSlides As Integer Dim intContain As Integer Dim slide1 As PowerPoint.Slide Dim shape1 As PowerPoint.Shape Dim intWrite As Integer Set fs1 = New Scripting.FileSystemObject strPath1 = "C:\Users\ (以下略)" 'ファイルの場所 strFind = "解答" ' 探したい語句 strFind2 = "別解" 'もう1個増やした strPathAll = strPath1 & "\all.ppt" '元のファイル名 strPathMost = strPath1 & "\most.ppt" '解答を抜いたファイル strPathAnswer = strPath1 & "\answer.ppt" '解答だけのファイル '全シートコピーしてから、後で消す fs1.CopyFile Source:=strPathAll, Destination:=strPathMost, Overwritefiles:=True fs1.CopyFile Source:=strPathAll, Destination:=strPathAnswer, Overwritefiles:=True ' Set pppPresenAll = ppaAppli.Presentations.Open(strPathAll) 'ファイルを開ける Set pppPresenMost = ppaAppli.Presentations.Open(strPathMost) Set pppPresenAnswer = ppaAppli.Presentations.Open(strPathAnswer) intNumSlides = pppPresenAll.Slides.Count '元のスライドの数 For intSlide = intNumSlides To 1 Step -1 ' 後ろのスライドから Set slide1 = pppPresenAll.Slides(intSlide) 'スライドの指定 intContain = 0 ' 各スライドごとに初期化 For Each shape1 In slide1.Shapes 'Shape についてのループ If shape1.HasTextFrame = msoTrue Then 'テキスト枠があるかチェック。 strText = shape1.TextFrame.TextRange.Text 'テキストを抜き出す intContain = intContain + InStr(strText, strFind) ' 語句が含まれるか調べる intContain = intContain + InStr(strText, strFind2) '2個めの語句 If intContain > 0 Then Exit For End If End If ' Next shape1 If intContain > 0 Then ' 1枚のスライドについて pppPresenMost.Slides(intSlide).Delete '解答スライドは消す ElseIf intContain = 0 Then pppPresenAnswer.Slides(intSlide).Delete '解答スライド以外は消す End If Next pppPresenMost.Save pppPresenMost.Close: Set pppPresenMost = Nothing pppPresenAnswer.Save pppPresenAnswer.Close: Set pppPresenAnswer = Nothing pppPresenAll.Close: Set pppPresenAll = Nothing ppaAppli.Quit: Set ppaAppli = Nothing End Sub