UniversoExcelForo

Respuesta a consultas.
Fecha de creación: 09.Abril.2012

Fundadores: Wibly,Tyno,Servando,Sakkar,Rosendo2,RMaximo,Railar,Mcoronel,Ioyama,Igtelo,Hugotron,Drochar,Dedos,Alberto,Adolfo

No se pueden hacer consultas de Excel o VBA por mensaje privado.
Utiliza el botón buscar del foro y te ahorras tiempo para obtener "ayuda".

No estás conectado. Conéctate o registrate

Ver el tema anterior Ver el tema siguiente Ir abajo  Mensaje [Página 1 de 1.]

1RESUELTO Generar ppt a partir de libro Excel el 27/09/16, 06:52 pm

mtrilce


Buenas tardes con todos,

Por favor, quisiera una macro que me permita generar desde un libro de Excel, un archivo ppt. En la creación debo indicar diferentes tipos de datos de cada hoja; por ejemplo:

De la hoja 1 que me copie la tabla B2:E10
De la hoja 2 que me copie el todos los gráficos
De la hoja 3 que me copie una tabla + 1 gráfico

Tengo la macro que me copia solo los gráficos, y es esta:

Sub CrearPowerPoint()

'Paso 1: Definición de variables
Dim archivoPPT As PowerPoint.Application
Dim diapositiva As PowerPoint.Slide
Dim hojaXLS As Excel.Worksheet
Dim grafico As Excel.ChartObject

'Paso 2: Abrimos el archivo de PowerPoint
Set archivoPPT = New PowerPoint.Application
archivoPPT.Presentations.Add

'Paso 3: Recorrer tods los gráficos en nuestro libro de Excel
For Each hojaXLS In ThisWorkbook.Worksheets
For Each grafico In hojaXLS.ChartObjects

'Paso 4: Agregamos una nueva diapositiva
archivoPPT.ActivePresentation.Slides.Add _
archivoPPT.ActivePresentation.Slides.Count + 1, ppLayoutBlank
archivoPPT.ActiveWindow.View.GotoSlide _
archivoPPT.ActivePresentation.Slides.Count
Set diapositiva = archivoPPT.ActivePresentation.Slides( _
archivoPPT.ActivePresentation.Slides.Count)

'Paso 5: Copiamos el gráfico en la diapositiva creada
hojaXLS.ChartObjects(grafico.Index).Chart.CopyPicture
diapositiva.Shapes.Paste

'Paso 6: Para una mejor organización, centramos la imagen copiada
archivoPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
archivoPPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'Paso 7: Cerramos el loop que hara que haga lo mismo con cada grafico
Next
Next

'Paso 7:Eliminamos las instancias creadas
Set diapositiva = Nothing
Set archivoPPT = Nothing
Set grafico = Nothing
Set hojaXLS = Nothing

End Sub

Pero lo que necesito es diferenciar los datos de cada hoja

Agradeceré mucho su ayuda

Saludos,

Marcela

mtrilce


Buenos días estimados amigos...

¿Alguien por ahí que pueda darme una mano?

He buscado muchas referencias que pueda adaptar, sin tener éxito. En verdad que su ayuda sería muy importante.

Gracias desde ya

Marcela

mtrilce


Estimados amigos,

Finalmente, con ayuda de algunos expertos, pude encontrar la solución. Copio acá la macro por si a alguno de ustedes les puede servir también,

Saludos,

Marcela

[ltr]Option Explicit

Dim PowerPointApp As Object
Dim myPresentation As Object

Sub ExcelRangeToPowerPoint()
'Create an Instance of PowerPoint
On Error Resume Next

'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False

'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add

'copy worksheets into slide
Call InsertSlideAndCopy(Worksheets("Company Data").Range("A5:C16")) '-----------------
Call InsertSlideAndCopy(Worksheets("Company Data").Shapes("Graph1")) '-----------------
Call InsertSlideAndCopy(Worksheets("Company Data (2)").Range("B2:D13"))
Call InsertSlideAndCopy(Worksheets("Company Data (3)").Range("C3:E14"))
Call InsertSlideAndCopy(Worksheets("Company Data (4)").Range("D4:F15"))

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False
End Sub

Private Sub InsertSlideAndCopy(O As Object)
Dim mySlide As Object, myShape As Object

'Add a slide to the Presentation
Set mySlide = myPresentation.slides.Add(myPresentation.slides.Count + 1, 11) '11 = ppLayoutTitleOnly '----------------

'Copy Excel Range
O.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 ' 2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

End Sub [/ltr]

Ver el tema anterior Ver el tema siguiente Volver arriba  Mensaje [Página 1 de 1.]

Permisos de este foro:
No puedes responder a temas en este foro.