Next without For error

[praveenlal]

Hi All,

I've written this code but getting Compile Error = Next without For error. Any expert help please

Sub Create_PPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim slde As PowerPoint.slide
Dim shp As PowerPoint.shape
Dim wb As Workbook
Dim rng As range

Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vSlide_No As Long
Dim expRng As range

Dim adminSh As Worksheet
Dim configRng As range
Dim xlfile$
Dim pptfile$

Application.DisplayAlerts = False

Set adminSh = ThisWorkbook.Sheets("Data")
Set configRng = adminSh.range("rng_sheet")

xlfile = adminSh.[excelPth]
pptfile = adminSh.[pptPath]

Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)

Set excelPth = adminSh.[excelPth]
Set pptPath = adminSh.[pptPath]

Set expRng = Sheets(vSheet$).range(vRange$)
Set slde = pre.Slides(vSlide_No)
Set shp = slde.Shapes(1)

wb.Activate

For Each rng In configRng

With ThisWorkbook.Sheets("Data")

wb.Sheets(rng.Value).Activate

With adminSh
vSheet$ = .Cells(rng.Row, 4).Value
vRange$ = .Cells(rng.Row, 5).Value
vWidth = .Cells(rng.Row, 6).Value
vHeight = .Cells(rng.Row, 7).Value
vTop = .Cells(rng.Row, 8).Value
vLeft = .Cells(rng.Row, 9).Value
vSlide_No = .Cells(rng.Row, 10).Value
End With

wb.Activate
Sheets(vSheet$).Activate
expRng.Copy

slde.Shapes.PasteSpecial ppPasteBitmap

With shp

.Top = vTop
.Left = vLeft
.Width = vWidth
.Height = vHeight

End With

Set shp = Nothing
Set slde = Nothing

Application.CutCopyMode = False

Next rng ''''GETTING ERROR ON THIS LINE''''

pre.Save

Set pre = Nothing
Set ppt_app = Nothing
Set expRng = Nothing
wb.Close False
Set wb = Nothing

Application.DisplayAlerts = True

End Sub

 

[GWteB]

Made some changes, but based solely on the object logic, as my Powerpoint knowledge is extremely limited.
Code has not been tested.
As requested before, in future posts please put your code between code tags:

Sub Create_PPT()

    Dim myPresentation As Object
    Dim mySlide As Object
    Dim PowerPointApp As Object
    Dim shp As Object
    Dim mySlideArray As Variant
    Dim myRangeArray As Variant
    Dim x As Long
    Dim wb As Workbook
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim sh4 As Worksheet
    Dim sh5 As Worksheet
    Dim sh6 As Worksheet

    Set wb = ActiveWorkbook
    Set sh1 = ThisWorkbook.Sheets("Close")
    Set sh2 = ThisWorkbook.Sheets("Trend")
    Set sh3 = ThisWorkbook.Sheets("Total_Cloud_Chart")
    Set sh4 = ThisWorkbook.Sheets("AWS_Summary_Chart")
    Set sh5 = ThisWorkbook.Sheets("Compute_Chart")
    Set sh6 = ThisWorkbook.Sheets("Storage_Chart")

    On Error Resume Next
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    Err.Clear
    
    If PowerPointApp Is Nothing Then
        MsgBox "PowerPoint Presentation is not opened, aborting."
        Exit Sub
    End If

    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    On Error GoTo 0

    PowerPointApp.ActiveWindow.Panes(2).Activate

    Set myPresentation = PowerPointApp.ActivePresentation

    mySlideArray = Array(3, 4, 5, 6, 7, 8)

    myRangeArray = Array(sh1.Range("A1:F14"), sh2.Range("A1:Q28"), _
                         sh3.Range("A1:P36"), sh4.Range("A1:AA26"), sh5.Range("A1:AA40"), sh6.Range("C1:AC28"))

    For x = LBound(mySlideArray) To UBound(mySlideArray)

        myRangeArray(x).Copy

        On Error Resume Next
        ' Set shp = PowerPoint.ActiveWindow.Selection.ShapeRange    'amended as per below <<<<<<<<<<<<<<<
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange   'will probably not work as intended I'm afraid
        On Error GoTo 0

        If Not shp Is Nothing Then              ' added <<<<<<<<<<
            With myPresentation.PageSetup
                shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2) 'GETTING ERROR ON THIS LINE'
                shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
            End With
        Else                                    ' added <<<<<<<<<<
            ' no shape selected                 ' added <<<<<<<<<<
        End If                                  ' added <<<<<<<<<<
    Next x

    Application.CutCopyMode = False
    
    ' PowerPoint.Save   'amended as per below <<<<<<<<<<<<<<<
    myPresentation.Save

    MsgBox "Report Completed"
End Sub

 

[praveenlal]

T

Made some changes, but based solely on the object logic, as my Powerpoint knowledge is extremely limited.
Code has not been tested.
As requested before, in future posts please put your code between code tags:

View attachment 60863

Sub Create_PPT()

    Dim myPresentation As Object
    Dim mySlide As Object
    Dim PowerPointApp As Object
    Dim shp As Object
    Dim mySlideArray As Variant
    Dim myRangeArray As Variant
    Dim x As Long
    Dim wb As Workbook
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim sh3 As Worksheet
    Dim sh4 As Worksheet
    Dim sh5 As Worksheet
    Dim sh6 As Worksheet

    Set wb = ActiveWorkbook
    Set sh1 = ThisWorkbook.Sheets("Close")
    Set sh2 = ThisWorkbook.Sheets("Trend")
    Set sh3 = ThisWorkbook.Sheets("Total_Cloud_Chart")
    Set sh4 = ThisWorkbook.Sheets("AWS_Summary_Chart")
    Set sh5 = ThisWorkbook.Sheets("Compute_Chart")
    Set sh6 = ThisWorkbook.Sheets("Storage_Chart")

    On Error Resume Next
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    Err.Clear
   
    If PowerPointApp Is Nothing Then
        MsgBox "PowerPoint Presentation is not opened, aborting."
        Exit Sub
    End If

    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    On Error GoTo 0

    PowerPointApp.ActiveWindow.Panes(2).Activate

    Set myPresentation = PowerPointApp.ActivePresentation

    mySlideArray = Array(3, 4, 5, 6, 7, 8)

    myRangeArray = Array(sh1.Range("A1:F14"), sh2.Range("A1:Q28"), _
                         sh3.Range("A1:P36"), sh4.Range("A1:AA26"), sh5.Range("A1:AA40"), sh6.Range("C1:AC28"))

    For x = LBound(mySlideArray) To UBound(mySlideArray)

        myRangeArray(x).Copy

        On Error Resume Next
        ' Set shp = PowerPoint.ActiveWindow.Selection.ShapeRange    'amended as per below <<<<<<<<<<<<<<<
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange   'will probably not work as intended I'm afraid
        On Error GoTo 0

        If Not shp Is Nothing Then              ' added <<<<<<<<<<
            With myPresentation.PageSetup
                shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2) 'GETTING ERROR ON THIS LINE'
                shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
            End With
        Else                                    ' added <<<<<<<<<<
            ' no shape selected                 ' added <<<<<<<<<<
        End If                                  ' added <<<<<<<<<<
    Next x

    Application.CutCopyMode = False
   
    ' PowerPoint.Save   'amended as per below <<<<<<<<<<<<<<<
    myPresentation.Save

    MsgBox "Report Completed"
End Sub

Thanks GWteB... only getting Message "Report Completed", excel data is not pasted in any PPT slide

 

[praveenlal]

Sub PasteMultipleSlides()

'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'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 Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
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

'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(3).Activate

'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation

'List of PPT Slides to Paste to
MySlideArray = Array(3, 4, 5, 6, 7, 8)

'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet4.Range("A1:F14"), Sheet3.Range("A1:Q28"), _
Sheet5.Range("A1:P36"), Sheet6.Range("A1:AA26"), Sheet7.Range("A1:AA40"), _
Sheet8.Range("C1:AC28"))

'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy

'Paste to PowerPoint and position
On Error Resume Next
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0

'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.width \ 2) TRIED NEW CODE BUT GETTING SAME ERROR HERE
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With

Next x

'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"

End Sub