Need to Export Excel sheet range to Multiple Powerpoint Slides

[eresylva]

Hello Comrades,

I am new to Excel VBA so please excuse any misuse of excel terminologies. I used some code I found on a Youtube tutorial video to export from excel to PowerPoint using VBA. The code worked to an extent until I tried to modify it - now I'm stuck.


I want to export a range of cells to PowerPoint but the cell values change based on a scrollbar I inserted. This is what it looks like:

I want to export the puzzle, which is Range("M1:U11"), but I want each puzzle from 1 to 300 to appear on its own separate slide on the Powerpoint Presentation. So When A6 = 1, puzzle no 1 is exported, when A = 2, puzzle no 2 is exported, and so on and so forth.



I tried adding a For and if loop (I don't fully know how thoses work tbh) but it copied and pasted cell "A6" a 155 times! Long story short, I'm stuck and I need your help. Here's the code:

Private Sub CommandButton1_Click()

'Declare our Variables
Dim r As Range
Dim powerpointapp As Object
Dim mypresentation As Object
Dim myslide As Object
Dim myshape As Object


'assigning range into variable
Set r = ThisWorkbook.Worksheets("Sheet1").Range("M1:U11")

'If we have already opened powerpoint
Set powerpointapp = GetObject(class:="PowerPoint.Application")
                  
'If powerpoint is not opened
If powerpointapp Is Nothing Then Set powerpointapp = CreateObject(class:="PowerPoint.Application")

'To create a new presentation
Set mypresentation = powerpointapp.Presentations.Add

 
 'Loop through all the values in "A6"
         'If Range("A6") = loop 1 To 100 Then Range("M1:U11").Select
         'Copy the Selection
         'Paste each iteration on a new slide on Powerpoint

Set myslide = mypresentation.slides.Add(1, 11)

r.Copy

'to paste range
myslide.Shapes.PasteSpecial DataType:=2
Set myshape = myslide.Shapes(myslide.Shapes.Count)
myshape.Left = 250
myshape.Top = 150

powerpointapp.Visible = True
powerpointapp.Activate

'to clear the cutcopymode from clipboard
Application.CutCopyMode = False


'Keep going if thee is an error
On Error Resume Next

End Sub

Thanks in advance!

 

[sijpie]

Hey, sudoku puzzles! my favourites...

 

[sijpie]

Here is the code for four puzzles to a page.

Option Explicit

' Macro to generate 300 Sudoku puzzles and place these 4 to a page _
  in Powerpoint. The page also contains a footer. _
  Made by Sijpie on MrExcel


Private Sub CommandButton1_Click()

    'Declare  Variables
    Dim rR As Range, rA6 As Range
    Dim oPowerPointApp As Object
    Dim oPresentation As Object
    Dim oSlide As Object
    Dim oShape As Object
    Dim i As Integer, dFct As Double
    Dim sFooter As String
    
    
    'assigning ranges into variables
    Set rR = ThisWorkbook.Worksheets("Sudoku").Range("M1:U11")  '<<< Use correct sheet name
    Set rA6 = ThisWorkbook.Worksheets("Sudoku").Range("A6")     '<<< Use correct sheet name
    
    sFooter = "Copyright - This is my footer text - No unauthorised copying or publication" '<<<<< Modify footer to suit. _
                                                You can also have the footer text in a cell and put the cell address here
    
    'Check if  powerpoint already opened
    Set oPowerPointApp = GetObject(class:="PowerPoint.Application")
                      
    If oPowerPointApp Is Nothing Then
        'Powerpoint is not opened, so open PPT
        Set oPowerPointApp = CreateObject(class:="PowerPoint.Application")
    End If
    
    'Create a new presentation
    Set oPresentation = oPowerPointApp.Presentations.Add
    
     
    'Now generate 300 puzzles and paste these 4 to a slide
             
    For i = 1 To 36    'Loop A6 through all values from 1 to 300
        rA6 = i
        
        'add new slide for every four puzzles
        If i Mod 4 = 1 Then
            With oPresentation
                'Add slide, blank format, vertical A4
                Set oSlide = .Slides.Add(.Slides.Count + 1, 12) '.ppLayoutBlank)
                With .PageSetup
                    .SlideOrientation = msoOrientationVertical
                    .SlideSize = 3  '.ppSlideSizeA4Paper
                End With
        
                'Add footer textbox
                With oSlide.Shapes _
                .AddTextbox(msoShapeRectangle, 0, 720, 540, 140).TextFrame
                'set to bottom (720 points down), left aligned (0), full page width (540 points), 140 pts high
                    'Add text and horizontal align text in textbox
                    .TextRange.Text = sFooter
                    .MarginBottom = 10
                    .MarginLeft = 10
                    .MarginRight = 10
                    .MarginTop = 10
                    .HorizontalAnchor = msoAnchorCenter
                    .TextRange.Font.Size = 10
                End With
                
            End With
        
        End If
        
        'Copy the puzzle
        rR.Copy
        
        'to paste range
        oSlide.Shapes.PasteSpecial DataType:=2
        'set shape object to last created shape
        Set oShape = oSlide.Shapes(oSlide.Shapes.Count)
        'Resize the puzzle. dFct is the sizing factor. Increase it to make the puzzle larger
        dFct = 0.85
        oShape.Height = oShape.Height * dFct
        oShape.Width = oShape.Width * dFct
        
        'position the shape depending on 1st, 2nd, 3rd or 4th
        Select Case i Mod 4
            Case 1  '1st
                oShape.Left = 50
                oShape.Top = 150
            Case 2  '2nd
                oShape.Left = 300
                oShape.Top = 150
            Case 3  '3rd
                oShape.Left = 50
                oShape.Top = 400
            Case 0  '4th
                oShape.Left = 300
                oShape.Top = 400
        End Select
    Next i
        
    oPowerPointApp.Visible = True
    oPowerPointApp.Activate
    
    'to clear the cutcopymode from clipboard
    Application.CutCopyMode = False
    
End Sub

 

[eresylva]

Thank you so much. I haven't tried it yet -- I have a bad case of h.pylori so I can't think straight. I just wanted to post my appreciation for taking your time to help me out with this. I honestly didn't think I would get this much help. Do you have a website or blog, I could follow and learn more about VBA programming?

I'll give it a try and post my feedback here. Thanks a bunch

 

[sijpie]

Don't have a website, but I could give you a course in exchange for a donation to a charity.

Hopefully you'll get over your illness soon.