View Full Version : [SOLVED:] Export Each Excel Row Text - to PPT
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
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
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
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
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
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
Thanks again snb,
I am happy to add this to my box of tools
Great man
you have a good day!:grinhalo:
dj
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
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
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:
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
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
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
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
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
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.