Excelのセルの内容でPPTのスライドを大量生成する

なぜこんなものを？

以前大学で研究していたときに、被験者に単純作業を繰り返してもらって反応の変化をみるという実験をしたことがあります。
ただその作業がパターン化してしまうと実験として意味がないので全くランダムなテストを作るためにExcelでランダムなテストをつくり、PPTに飛ばすということをやったことがあります。

もちろんVBAが使える人ばかりならPPT側のVBAだけでも良かったのですが、Excelのマクロワンクリックにすることによって誰でもセルの内容をPPTに簡単に変換することができます。

実際のコード

Sub ExcelToPPT()

  Dim ppt_app As Object 'PowerPoint
  Dim ppt_prs As Object 'PowerPoint Presentation
  Dim c As Long 'Column Number
  Dim r As Long 'Row Number
  Dim r_end As Long 'End Row Number
  Dim msg As String

  r_end = Range("A2").End(xlDown).Row
  If r_end >= 300 Then
    msg = "データが、" & Format(r_end, "#,##0") & "件あるため、処理に相当な時間がかかる可能性があります。実行しますか？"
    If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
  End If

  Set ppt_app = CreateObject("PowerPoint.Application")
  With ppt_app
    .Visible = True
    Set ppt_prs = .Presentations.Add
  End With

  For r = 1 To r_end - 1
  With ppt_prs.Slides
    .Add _
      Index:=r, _
      Layout:=12
End With
  
  ppt_prs.Slides(r).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=90.14, Top:=175.46, Width:=780.09, Height:=189.07).TextFrame _
    .TextRange.Text = ActiveSheet.Cells(r + 1, 1).Text
    
    
If r Mod 8 = 0 Then

With ppt_prs.Slides(r).Shapes(1)
    With .TextFrame.TextRange
        .Font.Size = 40
        .Font.Name = "游ゴシック Light"
        .ParagraphFormat.Alignment = 2
       .Text = "先ほどの文字列と一致するものがあれば" & vbCrLf & "対応する番号を囲んでください "
End With
End With

Else

With ppt_prs.Slides(r).Shapes(1)
    With .TextFrame.TextRange
        .Font.Size = 150
        .Font.Name = "Segoe UI"
        .ParagraphFormat.Alignment = 2
        
End With
End With
             
End If
  
  Next r

  Set ppt_prs = Nothing
  Set ppt_app = Nothing
  
 MsgBox "書き出しが終了しました。"
  
End Sub

使い方

なかなかこれを作成当時と同じ用に被験者実験目的で利用する人はいないかもしれませんが、ちょっと改良してあげることによってExcel上で発表スライドのアウトラインを構成してそれを元にPPTファイルを作ることに活かしたりはできるかもしれません。よいPPTライフを。