Macro para exportar lista de excel a títulos en power point
Amigo necesito ayuda para pasar una lista de excel a títulos en slides de power point y adicional insertar las imágenes que tiene la ubicación en otra columna
Estoy usando la siguiente sentencia pero me hace falta el buckle para crear las nuevas hojas con los nombres y el de insertar las fotos
Sub Ejemplo1()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim excelTable As Excel.Range
Dim archivoPPT As PowerPoint.Application
Dim diapositiva As PowerPoint.Slide
Dim tableranges As Excel.Range
Dim i As Integer
'Asignar la tabla que queremos copiar a la variable excelRange
Set excelTable = Worksheets("Ejemplo").Range("a2")
'Comprobar si PowerPoint esta abierto y en caso de no estarlo abrirlo
On Error Resume Next
Set pptApp = GetObject("", "PowerPoint.Application")
Err.Clear
If pptApp Is Nothing Then Set pptApp = CreateObject(class:="PowerPoint.Appliaction")
pptApp.Visible = True
pptApp.Activate
'Crear una nueva presentacion de PowerPoint
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
'Copiar la tabla de Excel
excelTable.Copy
'Pegar la tabla de Excel en PowerPoint y centrarla en la diapositiva
pptSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
Set pptApp = Nothing
Set pptPres = Nothing
Set pptSlide = Nothing
Set pptShape = Nothing
Set excelTable = Nothing
Set archivoPPT = Nothing
Set diapositiva = Nothing
Set tableranges = Nothing
End Sub
2 Respuestas
Inicia en la columna a2 y las fotos están en a3, pero hacia abajo puede variar entre 1500 y 2000 registros
Mil gracias man
[Hola nuevamente
No me queda claro, es decir ¿cada imagen está en la celda inmediata inferior de la celda con el "código"? Eso das a entender:
A2 = código
A3 = Imagen
A4 = Código
A5 = Imagen
etc...
Otra cosa, las imágenes no se insertan en las celdas, por lo que no es tan simple detectar una que se encuentre sobre una celda así que ¿dichas imágenes están "centradas" sobre cada celda o las sobre pasan?
Comentas
Abraham Valencia
Abraham buen día
Adjunto pantallazo de la base de datos, en la primera columna (A) se guarda la información que seria el titulo de la diapositiva y en la siguiente columna (B) se guarda la ruta donde se encuentran las fotos
Espero me entiendas un poco con esta imagen y me puedas ayudar. mil gracias
Ya con esos datos te dejo una propuesta que mantiene casi todo lo que usaste pero he cambiado lugares y agregado un bucle para que recorra tus datos:
Sub Ejemplo1()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim excelTable As Excel.Range
Dim archivoPPT As PowerPoint.Application
Dim diapositiva As PowerPoint.Slide
Dim tableranges As Excel.Range
Dim i As Integer
Dim UltimaFila As Long, x As Long
Dim Celda As Range
Dim shF As Shape
Let UltimaFila = Cells(Rows.Count, 1).End(xlUp).Row
Let x = 1
Set pptApp = GetObject("", "PowerPoint.Application")
If pptApp Is Nothing Then Set pptApp = CreateObject(class:="PowerPoint.Appliaction")
pptApp.Visible = True
pptApp.Activate
Set pptPres = pptApp.Presentations.Add
For Each Celda In Range("A2:A" & UltimaFila)
Set excelTable = Celda
Set pptSlide = pptPres.Slides.Add(x, ppLayoutBlank)
excelTable.Copy
pptSlide.Shapes.PasteSpecial (ppPasteEnhancedMetafile)
pptSlide.Shapes.AddPicture Filename:=Celda.Offset(0, 1).Value, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=100, Top:=100, Width:=70, Height:=70
Let x = x + 1
Set excelTable = Nothing
Set pptSlide = Nothing
Next Celda
Set pptApp = Nothing
Set pptPres = Nothing
Set pptShape = Nothing
Set archivoPPT = Nothing
Set diapositiva = Nothing
Set tableranges = Nothing
End SubSaludos]
Abraham Valencia
Amigo muchas gracias, creo que estamos a punto
Mira que la sentencia me esta generando este error de compilación
Al depurar me muestra el error en la siguiente
pptSlide.Shapes.AddPicture Filename:=Celda.Offset(0, 1).Value, _
savewithdocument:=msoTrue, LinkToFile:=msoFalse, Left:=100, Top:=100, Width:=70, Height:=70
Mil gracias
Ese error ocurre cuando la ruta y nombre que está en la celda no es estrictamente igual al del archivo. Rápidamente veo que tienes los nombres como "1" o "3", cuando se supone que debe ser "1.jpg" o "3.png" o etc.
Abraham Valencia
Que bien abraham mil gracias
Tengo un proyecto un poco más ambicioso y me gustaría tener su consejo
Pues no hay problema, solo cierra este tema y abre una nueva consulta.
Saludos]
Abraham Valencia