Export Each Excel Row Text - to PPT

[dj44]

Good Morning folks and community

I am trying to export each Row of my excel file to PPT.

It has my descriptions of various technical bits and bobs, that needs to be presenter friendly.

Now I have got a head start thanks to Mr Tolley here.

http://www.craig-tolley.co.uk/2011/0...xcel-workbook/

Sub CreateSlides()

Found on Mr Tolley site

'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
Set OWB = Excel.Application.Workbooks.Open("C:\Users\DJ-PC\PartDescriptions.xlsm")

'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)
'Loop through each used row in Column A
For i = 1 To WS.Range("A65536").End(xlUp).Row
    'Copy the first slide and paste at the end of the presentation
    ActivePresentation.Slides(1).Copy
    ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1)

    'Change the text of the first text box on the slide.
    ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value
Next

End Sub

I spent the whole day with various errors and what nots , so I overcame them, but I'm still not sure what to do - it runs - but no will it copy my row from excel into the power point.. I don't know why its playing so mean.



So to make it simple to understand


I have 2 Columns in Excel


Column A Part No - Column B - Description

PN384743 - This part belongs to the group TS234, Component CV2837 is required to .......etc


So each Row - would be a slide.


I would like to export each row into Excel as Text.

If any pro expert coder would not mind lending me their hand and helping me to solve this difficult case - I would be grateful very much

I would be really appreciative, as its not easy this coding - I can tell you

thank you very much folks for your help, your time is valued.


DJ

[snb]

Sub M_snb()
  with getobject("C:\Users\DJ-PC\PartDescriptions.xlsm")
    sn = Sheets(1).Cells(1).CurrentRegion.Resize(, 2)
    .close 0
  end with
    
  With CreateObject("Powerpoint.application")
    With .presentations.Add
      For j = 1 To UBound(sn)
        With .Slides.Add(1, 12)
          With .Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange
            .Text = sn(j, 1) & vbLf & sn(j, 2)
            .Font.Size = 38
          End With
        End With
      Next
    End With
  End With
End Sub

[dj44]

Hello snb,

and thank you very much for helping.

I ran this nice macro from PPT

error
sn = Sheets(1).Cells(1).CurrentRegion.Resize(, 2)


I run from excel - I get a new presentation with 1 slide - no text copied

what could it be - im not sure

thank you

DJ

[snb]

There should be any data in cell A1 in sheets(1) of workbook C:\Users\DJ-PC\PartDescriptions.xlsm
You should comment out or remove 'option explicit'.
I forgot a dot:

Sub M_snb() 
    With getobject("C:\Users\DJ-PC\PartDescriptions.xlsm") 
        sn = .Sheets(1).Cells(1).CurrentRegion
        .close 0 
    End With 
     
    With CreateObject("Powerpoint.application") 
        With .presentations.Add 
            For j = 1 To UBound(sn) 
                With .Slides.Add(1, 12) 
                    With .Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange 
                        .Text = sn(j, 1) & vbLf & sn(j, 2) 
                        .Font.Size = 38 
                    End With 
                End With 
            Next 
        End With 
    End With 
End Sub

[dj44]

Hello snb,

thank you very very much for fixing that code.

I can't believe it - worked like a charm.

Saving me hours of copy pasting

Well done!!


I guess you have done the good job of solving this case

many thanks again

DJ

[snb]

You can condense the code to:

Sub M_snb() 
    With getobject("C:\Users\DJ-PC\PartDescriptions.xlsm") 
        sn = .Sheets(1).Cells(1).CurrentRegion 
        .close 0 
    End With 
     
    With CreateObject("Powerpoint.application") 
        With .presentations.Add 
            For j = 1 To UBound(sn) 
                With .Slides.Add(1, 12).Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange 
                  .Text = sn(j, 1) & vbLf & sn(j, 2) 
                  .Font.Size = 38 
                End With 
            Next 
        End With 
    End With 
End Sub

[dj44]

Thanks again snb,

I am happy to add this to my box of tools

Great man

you have a good day!

dj

[snb]

You migth even consider:

Sub M_snb()
  With getobject("C:\Users\DJ-PC\PartDescriptions.xlsm")
    sn = .Sheets(1).Cells(1).CurrentRegion
    .close 0
  End With 
     
  With GetObject(, "Powerpoint.application")
    With .presentations.Add
      For j = 1 To UBound(sn)
        .slides.Add(1, 11).Shapes(1).TextFrame.TextRange = sn(j, 1) & vbLf & sn(j,2)
      Next
    End With
  End With
End Sub

[dj44]

snb,

you are being too kind and generous.

And not for me to take advantage of your good help, but I did have 1 questions - if you dont mind, otherwise I know I will get stuck again and have to post another thread


1. Am I able to export into to existing PPT - I have found many nice templates online to showcase the parts description

You don't have to code for me as you have done so much - a point in the right direction i would be happy.

thank you snb

DJ

[dj44]

Actually I think I may be able to insert the images via the photo album, but it has a black background.

I also had the good fortune to find this little gem

Insert Images into PPT

http://www.pptfaq.com/FAQ00352_Batch..._per_slide.htm

worked a treat

[snb]

I'd use:

Sub M_snb()
    sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir G:\OF\*.jpg /b/s").stdout.readall, vbCrLf), ".")
    
    With GetObject(, "Powerpoint.application")
      With .presentations.Add
         For j = 0 To ubound(sn)
           .slides.Add(.slides.Count + 1, 12).Shapes.AddPicture sn(j), -1, -1, 10, 10
         Next
      End With
    End With
End Sub

[dj44]

Hi snb,

your code is working very nicely - it does the good job.

I have been trying to export it to my existing PPT unsuccessfully,

Sub M_snb() 
    With getobject("C:\Users\DJ-PC\PartDescriptions.xlsm") 

   

        sn = .Sheets(1).Cells(1).CurrentRegion 
        .close 0 
    End With 
     
    With CreateObject("Powerpoint.application") 


    FlName = "C:\Users\DJ-PC\Desktop\DJPartDescriptions.PPTX"    ' this did not work

        With .presentations.Add 
            For j = 1 To UBound(sn) 
                With .Slides.Add(1, 12).Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange 
                  .Text = sn(j, 1) & vbLf & sn(j, 2) 
                  .Font.Size = 38 
                End With 
            Next 
        End With 
    End With 
End Sub

Open Existing PPT

Dim FlName As String

    FlName = "C:\Users\DJ-PC\Desktop\DJPartDescriptions.PPTX"

    On Error Resume Next
    Set oPPApp = GetObject(, "PowerPoint.Application")

    If Err.Number <> 0 Then
        Set oPPApp = CreateObject("PowerPoint.Application")

and then stuck

I have tried everything - nothing works

if you don't mind and know how I can export it into my current PPT - I will be more than obliged to your kindness

thank you very much

DJ

[snb]

Sub M_snb() 
  With getobject("C:\Users\DJ-PC\PartDescriptions.xlsm") 
    sn = .Sheets(1).Cells(1).CurrentRegion 
    .close 0 
  End With 
     
  With getObject("C:\Users\DJ-PC\Desktop\DJPartDescriptions.PPTX") 
    For j = 1 To UBound(sn) 
      With .Slides.Add(1, 12).Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange 
        .Text = sn(j, 1) & vbLf & sn(j, 2) 
        .Font.Size = 38 
      End With 
    Next 
  End With 
End Sub

[dj44]

Snb,

thank you yes this added it it my ppt.

the last thing I am trying to work out is - am i able to insert it into my current slides.

Or is that too complicated more

I have my slides layed out -

With active.Slides.insert(1, 12).Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange   would this work

1 row INSERT into 1 existing slide text box

thank you for going the extra mile - I apologize for it dragging on - I just don't know how to insert it into current slide

I am grateful of your valuable time

dj

[snb]

Sub M_snb() 
    With getobject("C:\Users\DJ-PC\PartDescriptions.xlsm") 
        sn = .Sheets(1).Cells(1).CurrentRegion 
        .close 0 
    End With 
     
    With getObject("C:\Users\DJ-PC\Desktop\DJPartDescriptions.PPTX") 
        For j = 1 To UBound(sn) 
            With .Slides(j).Shapes.AddTextbox(1, 120, 120, 270, 100).TextFrame.TextRange 
                .Text = sn(j, 1) & vbLf & sn(j, 2) 
                .Font.Size = 38 
            End With 
        Next 
    End With 
End Sub

[dj44]

snb,

You ROCK!!

I have a hardrive full of old power points so many of them - thanks to your help - no more copy and pasting 1000+ slides for me

You have made my good week


thank you for revising the code - many times - that was very generous of you

a very patient and helpful Young Gentleman coder in the community

now i looked all over since yesterday - i still couldn't figure it out

I thank you for your good grace and teaching me how to code - i can learn how to adapt it now

You have the best week ever now

cheers

DJ