Create Slide Per Picture - excel

Question

I have below macro that brings file from saved file from excel to PowerPoint what I need is to update the macro to bring one file per slide instead of bringing all into one slide
Sub CreatePagePerComment()
Dim PowerPointApp As Object
Dim myPPTX As Object
Dim mySlide As Object
Dim pptxNm As String
Dim pptNm As Range
Dim rSht As Worksheet
Dim oSht As Worksheet
Dim oPicture As Object
Set pptNm = ThisWorkbook.Sheets("Sheet1").[PPTX_File]
Sheets("Sheet1").[PPTX_File].Value = pptNm.Value
CONFIRM_PPTX_APP:
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then
'Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
With pptNm.Validation
.Delete 'delete previous validation
End With
MsgBox "No PowerPoint file is open. Please open the PowerPoint file to where you " & _
"would like to export this table.", vbOKOnly + vbCritical, ThisWorkbook.Name
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
GET_PPTX_FILENAME:
If pptNm.Value = "" Then
MsgBox "Please select the PowerPoint file name, from the drop down list, to where you want to export the Headcount Review summary table." & _
Chr(10) & Chr(10) & "This Macro has selected the cell that contains a list of all open PowerPoint files. " & Chr(10) & Chr(10) & _
"If your file is not listed, please confirm it is open, then select any other cell, then return to this cell for " & _
"a refreshed file name list.", vbOKOnly + vbCritical, "No PowerPoint File Selected"
pptNm.Select
Exit Sub
Else:
If InStr(1, pptNm.Value, "ppt") > 0 Then
pptxNm = pptNm.Value
ElseIf InStr(1, pptNm.Value, "pptx") > 0 Then
pptxNm = pptNm.Value & ".pptx"
ElseIf InStr(1, pptNm.Value, "pptm") > 0 Then
pptxNm = pptNm.Value & ".pptm"
End If
End If
pptxNm = "NN Commitment Cards.pptm"
Set myPPTX = PowerPointApp.Presentations(pptxNm)
PowerPointApp.Visible = True
PowerPointApp.Activate
'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String
sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3
ADD_NEW_SLIDE:
Dim SlideCnt As Integer
Set mySlide = myPPTX.Slides.Add(sld_no + 1, 12)
mySlide.Select
mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
'mySlide.Shapes.AddOLEObject Left:=10, Top:=10, Width:=(7.5 * 72), Height:=(10 * 72),
' Filename:=[B1].Value & "\" & [A132].Value & ".pdf", displayasicon:=msoFalse, link:=msoTrue
For Each cel In [A3:A4]
If Cells(cel.Row, [A1].Column).Value <> "" Then
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
Set oSlide = myPPTX.Slides(1)
With oPicture
.Width = 7 * 72
.Height = 8 * 72
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = oPicture.Height / 1.85
.Name = cel.Value
.Line.Weight = 0.5
.Line.Visible = msoTrue
.LockAspectRatio = msoTrue
.Left = 1.5 * 72
.Top = 1.5 * 72
With myPPTX.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With
End With
End If
End Sub
What is the required tweak that I need to update in this macro to do so?

Answer 1

I am assuming the rest of your code is working and focusing only on your specific question. First, there is no reference to oSlide in your code, so I assume that's some typo. From my reading of your code, you add a new slide to the current slide and add a picture to it (or not since that section of code is commented out). Then, based on the content of [A3:A4], you want to add new slides, each with a new picture. I have discarded commented code and kept your code as unmodified as possible in providing this solution (change the required section fo your code):
'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String
sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3
ADD_NEW_SLIDE:
Dim SlideCnt As Integer
SlidCnt = 0
For Each cel In [A3:A4]
If Cells(cel.Row, [A1].Column).Value <> "" Then
SlideCnt = SlideCnt + 1
Set mySlide = myPPTX.Slides.Add(sld_no + SlideCnt, 12)
mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
With oPicture
.Width = 7 * 72
.Height = 8 * 72
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = oPicture.Height / 1.85
.Name = cel.Value
.Line.Weight = 0.5
.Line.Visible = msoTrue
.LockAspectRatio = msoTrue
.Left = 1.5 * 72
.Top = 1.5 * 72
With myPPTX.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With
End With
End If
Next cel