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/06/08/vba-create-powerpoint-slide-for-each-row-in-excel-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).TextFr ame.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.:igiveup:. 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:old:

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


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.:grinhalo:

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:grinhalo:

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!:grinhalo:

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.:friends:

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:o:


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

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_Insert_a_folder_full_of_pictures-_one_per_slide.htm

worked a treat:grinhalo:

[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.:grinhalo:

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:sad2:

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.:checkmark

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:biggrin:

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!!:super:

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 :biglaugh:

You have made my good week:joy:


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 :igiveup:

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

You have the best week ever now

cheers:beerchug:

DJ