分担君

分担君のソースコードです。

Sub Make_PPT()

Dim I As Long
Dim row_max As Long

row_max = Range("B300").End(xlUp).Row

Dim objPw1 As Object
Set objPw1 = CreateObject("PowerPoint.application")

'表紙を開いて、あとを追加する

'表紙のスライドを作成
objPw1.presentations.Open (Cells(2, 2))
objPw1.Visible = True

'後のスライドを追加する
For I = 3 To row_max
  If Dir(Cells(I, 2)) <> "" Then
    objPw1.presentations.Open (Cells(I, 2))
    objPw1.presentations(objPw1.presentations.Count).Slides.Range.Copy
    objPw1.presentations(1).Slides.Paste
    objPw1.presentations(objPw1.presentations.Count).Close
  End If
Next I

  '別名で保存する
  Dim f_name As String
  
  f_name = InputBox("保存するファイル名を入力してください", "ファイル名", "newfile" & Year(Date) & Month(Date) & Day(Date))
  objPw1.presentations(1).SaveAs (ActiveWorkbook.Path & "\" & f_name & ".pptx")


End Sub

Sub Make_PPT()

Dim I As Long

Dim row_max As Long

row_max = Range("B300").End(xlUp).Row

Dim objPw1 As Object

Set objPw1 = CreateObject("PowerPoint.application")

'表紙を開いて、あとを追加する

'表紙のスライドを作成

objPw1.presentations.Open (Cells(2, 2))

objPw1.Visible = True

'後のスライドを追加する

For I = 3 To row_max

If Dir(Cells(I, 2)) <> "" Then

objPw1.presentations.Open (Cells(I, 2))

objPw1.presentations(objPw1.presentations.Count).Slides.Range.Copy

objPw1.presentations(1).Slides.Paste

objPw1.presentations(objPw1.presentations.Count).Close

End If

Next I

'別名で保存する

Dim f_name As String

f_name = InputBox("保存するファイル名を入力してください", "ファイル名", "newfile" & Year(Date) & Month(Date) & Day(Date))

objPw1.presentations(1).SaveAs (ActiveWorkbook.Path & "\" & f_name & ".pptx")

End Sub

MENU

VBA関連

VBA関連