PDA

View Full Version : [SOLVED] Copy row cells to powerpoint



TheVoodoo
02-12-2014, 01:22 AM
Dear all,
i've been seeking the forum but can't find what i need:
here is the problem:
i have an excel work sheet with some data in several rows, i need to:
open a powerpoint presentation then:

for row 1
copy cell A1 as text into powerpoint slide1
copy cell B1 as text into powerpoint slide 1
copy cell C1 as text into powerpoint slide 1

for row 2
copy cell A2 as text into powerpoint slide2
copy cell B2 as text into powerpoint slide 2
copy cell C2 as text into powerpoint slide 2

do the same for all rows wich contain data, each row in a different powerpoint slide.

can someone help me on this topic?

thanks in advance
P.S i'm a noobie in VBA

mancubus
02-12-2014, 03:34 AM
welcome to VBAX.

try this:



Sub CopyCellAsTextBoxTextToPPTSlide()
'requires a reference to Microsoft PowerPoint
'In VBE: tools, references, check Microsoft PowerPoint X.0 Object Library

Dim oPPT As PowerPoint.Application
Dim oPres As Presentation
Dim oSld As Slide
Dim LR As Long, LC As Long

Set oPPT = CreateObject("PowerPoint.Application")
oPPT.Visible = True
Set oPres = oPPT.Presentations.Add

With ActiveSheet
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To LR
Set oSld = oPres.Slides.Add(i, ppLayoutBlank)
For j = 1 To LC
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 15, 50 * j + 5, 500, 10 'adjust numbers here to suit
oSld.Shapes(j).TextFrame.TextRange.Text = .Cells(i, j).Value
Next
Next
End With
End Sub

TheVoodoo
02-12-2014, 05:22 AM
Thanks Mancubus, you're the man.........
the code works exactly as i requested. AWESOME"
another question, would it be possible to customize the code in order to tell the code to copy only specific columns for example A, C, K etc.

When in the beginning i posted the question i thought that hiding the not needed columns would have solved the problem, but the code copies also the hidden cells.
thanks in advance....

mancubus
02-12-2014, 05:52 AM
you are welcome.


Sub CopyCellAsTextBoxTextToPPTSlide_Rev()
'requires a reference to Microsoft PowerPoint
'In VBE: tools, references, check Microsoft PowerPoint X.0 Object Library

Dim oPPT As PowerPoint.Application
Dim oPres As Presentation
Dim oSld As Slide
Dim LR As Long, CntC As Long

Set oPPT = New PowerPoint.Application
oPPT.Visible = True
Set oPres = oPPT.Presentations.Add

With ActiveSheet
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
CntC = 4 'change to actual number of cells from the same row
For i = 1 To LR
Set oSld = oPres.Slides.Add(i, ppLayoutBlank)
For j = 1 To CntC
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 15, 50 * j + 5, 500, 10
oSld.Shapes(j).TextFrame.TextRange.Text = .Cells(i, Choose(j, "B", "C", "F", "J")).Value 'add or remove column letters to suit
Next
Next
End With
End Sub

TheVoodoo
02-12-2014, 06:04 AM
Thanks, merci, Danke , Grazie, Gracias.....
exactly what i meant.

mancubus
02-12-2014, 06:21 AM
you are welcome. im glad it helped. pls mark the thread as solved from the Thread Tools dropdown which is above the first post.

TheVoodoo
02-26-2014, 08:35 AM
Hello mancubus,
i haven't closed the topic yet because i'm struggling to solve the following problem:
integrate the opening of a powerpoint template selectable from a directory and then let the code run.
could you help me for the last time?

regards and thanks in advance

mancubus
02-26-2014, 09:00 AM
hi.

to browse for a file, try this.


Sub CopyCellAsTextBoxTextToPPTSlide_Rev()
'requires a reference to Microsoft PowerPoint
'In VBE: tools, references, check Microsoft PowerPoint X.0 Object Library

Dim oPPT As PowerPoint.Application
Dim oPres As Presentation
Dim oSld As Slide
Dim LR As Long, CntC As Long
Dim MyPpt As String

MyPpt = Application.GetOpenFilename("Powerpoint Presentations,*.ppt*")
If MyPpt = "False" Then 'user clicked Cancel button
MsgBox "Please select a presentation! Quitting..."
Exit Sub
End If

Set oPPT = New PowerPoint.Application
oPPT.Visible = True
Set oPres = oPPT.Presentations.Open(MyPpt)

With ActiveSheet
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
CntC = 4 'change to actual number of cells from the same row
For i = 1 To LR
Set oSld = oPres.Slides.Add(i, ppLayoutBlank)
For j = 1 To CntC
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 15, 50 * j + 5, 500, 10
oSld.Shapes(j).TextFrame.TextRange.Text = .Cells(i, Choose(j, "B", "C", "F", "J")).Value 'add or remove column letters to suit
Next
Next
End With
End Sub

TheVoodoo
02-26-2014, 12:20 PM
What to say....
your simply the best. Thanks for your support

KYCH
03-08-2014, 02:02 PM
Hi,

It took me a while surfing several days, and checking some codes, I have 0 experience, this is why i want to share it with others and thanks for all the experts that help us.

Here is the code that enables you copy especific cells ranges from the same, or different sheets to slides (in the same order that is written in the code). As well alignment ** the exported images in PPT slide. I have modified the original code from 'By Christos Samaras, '.myengineeringworld'. Also available in that web, export excel table to tables in PPT. However the script hereunder has been changed to copy cells and paste them as images in PPT. As Usual needs to be activated Micros**t Powerpoint.




Option Explicit

'Both subs require a reference to Micros**t PowerPoint xx.x Object Library.
'where xx.x is your **fice version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).

'Declaring the necessary Power Point variables, whick are used in both subs.
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Sub TablesToPowerPoint()

'Exports the range A1:C5 from each sheet to a new Power Point
'presentation as table. Each range is copied to a new slide.

'By Christos Samaras 'Modified by KYCH

Dim ws As Worksheet

'Open Power Point and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add

'Show the Power Point application.
pptApp.Visible = True

'Transfer the data from the selected range from the same or different sheets,
'to the Power Point presentation.
'the order specified per each line will appear in consecutive slide in ppt

Sheet1.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("B1:17"))
Sheet4.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("B8:W25"))
Sheet2.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("B7:H19"))
Sheet2.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("B20:H29"))
Sheet2.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("B30:H50"))

'Return the "focus" to the frist sheet.
ActiveWorkbook.Worksheets(1).Activate

'Infrom the user that the macro finished.
MsgBox "The report was sent to PPT!", vbInformation, "Done"

End Sub

Private Sub ExcelTableToPowerPoint(xlRange As Range)

'Copies an Excel Table as picture to Power Point.

'By Christos Samaras
'.myengineeringworld.

'Check if the range is valid.
If Application.Intersect(xlRange, ActiveSheet.Range("A1:XFD1048576")) Is Nothing Then
MsgBox "Sorry, the range you selected is not valid!", vbCritical, "Invalid range"
Exit Sub
End If

KYCH
03-09-2014, 03:54 AM
'Copy the range.
xlRange.CopyPicture

'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)

'Paste the picture and adjust its position
With pptSlide.Shapes.Paste
.Align msoAlignCenters, True
.Top = 50
.Left = 10
.Width = 700

End With


End Sub

Gehring
04-10-2014, 02:38 PM
Hey guys, I'm new here.

I need a little help. Mancubus' code is great, but is it possible to make a little change?

Like format the text (font size, color and style) when you copy them to power point.

My code is the following, I would like to apply different formatting for each Message Box.

Sub CopyCellAsTextBoxTextToPPTSlide()
'requires a reference to Microsoft PowerPoint
'In VBE: tools, references, check Microsoft PowerPoint X.0 Object Library

Dim oPPT As PowerPoint.Application
Dim oPres As Presentation
Dim oSld As Slide
Dim LR As Long, LC As Long

Set oPPT = CreateObject("PowerPoint.Application")
oPPT.Visible = True
Set oPres = oPPT.Presentations.Add

With ActiveSheet
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To LR
Set oSld = oPres.Slides.Add(i, ppLayoutBlank)

'Nombre
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 5, 5, 60, 10 'adjust numbers here to suit
oSld.Shapes(1).TextFrame.TextRange.Text = .Cells(i, 1).Value

'Résultat
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 60, 5, 650, 10 'adjust numbers here to suit
oSld.Shapes(2).TextFrame.TextRange.Text = .Cells(i, 2).Value

'Indicateurs
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 10, 70, 700, 10 'adjust numbers here to suit
oSld.Shapes(3).TextFrame.TextRange.Text = .Cells(i, 3).Value

'Pilote
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 550, 100, 150, 10 'adjust numbers here to suit
oSld.Shapes(4).TextFrame.TextRange.Text = .Cells(i, 4).Value

Next
End With
End Sub


Thanks in advance.

mancubus
04-11-2014, 02:07 AM
welcome to VBAX.

please use CODE tags when pasting a macro here. # button will do it for you.

here is something to play with.


Sub CopyCellAsTextBoxTextToPPTSlide()
'requires a reference to Microsoft PowerPoint
'In VBE: tools, references, check Microsoft PowerPoint X.0 Object Library
Dim oPPT As PowerPoint.Application
Dim oPres As Presentation
Dim oSld As Slide
Dim LR As Long, LC As Long
Set oPPT = CreateObject("PowerPoint.Application")
oPPT.Visible = True
Set oPres = oPPT.Presentations.Add
With ActiveSheet
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To LR
Set oSld = oPres.Slides.Add(i, ppLayoutBlank)

'Nombre
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 5, 5, 60, 10 'adjust numbers here to suit
With oSld.Shapes(1).TextFrame.TextRange
.Text = ActiveSheet.Cells(i, 1).Value
With .Font
.Size = 40
.Bold = msoCTrue
.Color.RGB = RGB(0, 255, 0) 'green
End With
End With

'Résultat
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 60, 5, 650, 10 'adjust numbers here to suit
With oSld.Shapes(2).TextFrame.TextRange
.Text = ActiveSheet.Cells(i, 2).Value
With .Font
.Size = 40
.Bold = msoCTrue
.Color.RGB = RGB(255, 0, 0) 'red
End With
End With

'Indicateurs
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 10, 70, 700, 10 'adjust numbers here to suit
With oSld.Shapes(3).TextFrame.TextRange
.Text = ActiveSheet.Cells(i, 3).Value
With .Font
.Size = 40
.Bold = msoCTrue
.Color.RGB = RGB(0, 0, 255) 'blue
End With
End With

'Pilote
oSld.Shapes.AddTextbox msoTextOrientationHorizontal, 550, 100, 150, 10 'adjust numbers here to suit
With oSld.Shapes(4).TextFrame.TextRange
.Text = ActiveSheet.Cells(i, 4).Value
With .Font
.Size = 40
.Bold = msoCTrue
.Color.RGB = RGB(255, 255, 0) 'yellow
End With
End With
Next
End Sub

Gehring
04-17-2014, 06:51 AM
Howdy,

Thanks for your reply Mancubus, the code worked great. I just did some adjustments.

When you say use code tags, I just have to put # in front of each line of the code?

Also, I have a new "problem":

I send e-mail once a week with a report from results from work. This e-mail is pretty much the same every week, only with a few changes, wich I get from a new Excel workbook every week.

In this workbook there are 3 sheets, and from the first two (2) sheets a need to copy a range (from each sheet) and paste in the body of the e-mail as an image.

And, for the third and last sheet, I have a graphic which is also copied and pasted in the body of the e-mail, summing up three images.

Then, I also make PDF files of these 2 ranges and 1 graphic and send as attachments with the e-mail.

I know there's a way to make it with VBA, I did some searching and found some stuff. But it's not as specific as I'd like to be.

Can someone help?

Maybe, if not here, I could create a thread on the Forum>Excel Help.

mancubus
04-17-2014, 07:35 AM
hey gehring.

you're welcome.

google gives me below link which seems to have answers to your questions:

http://www.rondebruin.nl/win/section1.htm