Macro que copie diferentes selecciones de rangos desde excel en un mismo archivo de PowerPoint
Sub Tabla_de_Excel_a_Ppoint() 'La macro copia el rango de Excel seleccionado en PowerPoint 'copiar rango selecionado Selection.Copy 'objeto para acceder al PowerPoint Dim ObjPowerPoint As New PowerPoint.Application 'objeto para crear la presentación Dim Presentacion As PowerPoint.Presentation 'objeto diapositiva Dim diapositiva As PowerPoint.slide ObjPowerPoint.Visible = True Set Presentacion = ObjPowerPoint.Presentations.Add Set diapositiva = Presentacion.Slides.Add(1, ppLayoutBlank) 'Pegado de las celdas Excel como vínculo diapositiva.Shapes.PasteSpecial(link:=True).Select 'Libera los objetos PowerPoint Set ObjPowerPoint = Nothing Set Presentacion = Nothing Set diapositiva = Nothing End Sub
Saludos quería saber como modificar este código para que el resultado sea el siguiente:
Cuando se seleccione más de un rango desde excel, se copie en orden correlativo de selección en un mismo archivo de powerpoint. Ya que con este código al seleccionar el primer rango se copia en un archivo ppt y al seleccionar un segundo rango se copia en un nuevo archivo ppt y asi sucesivamente y lo que necesito es que se cree un único archivo ppt con los rangos que yo seleccione (sin limite de selección de rangos).
1 respuesta
Te envío una nueva para que pruebes.
Sub Tabla_de_Excel_a_Ppoint()'La macro copia el rango de Excel seleccionado en PowerPoint 'objeto para acceder al PowerPointDim ObjPowerPoint As New PowerPoint.Application'objeto para crear la presentaciónDim Presentacion As PowerPoint.Presentation'objeto diapositivaDim diapositiva As PowerPoint.slide 'copiar rango selecionadoSelection.CopyIf Range("AB1") = "" Then ObjPowerPoint.Visible = True Set Presentacion = ObjPowerPoint.Presentations.Add Set diapositiva = Presentacion.Slides.Add(Presentacion.Slides.Count + 1, ppLayoutBlank) 'Pegado de las celdas Excel como vínculo diapositiva.Shapes.PasteSpecial(link:=True).Select Range("AB1") = "X"Else Set PPApp = GetObject(, "PowerPoint.Application") Set ppFile = PPApp.ActivePresentation ppFile.Slides.Add(ppFile.Slides.Count + 1, 11).Select PPApp.ActiveWindow.View.PasteSpecial(link:=True).Select End If 'Libera los objetos PowerPointSet ObjPowerPoint = NothingSet Presentacion = NothingSet diapositiva = Nothing End Sub
Indicaciones:
Guarda tu libro, cierra y vuelve a abrir el libro (esto es para que se borre la X que está en AB1.
Deberás tener un presentación abierta de power point, si tienes más de una, de creará una diapositiva en la última que hayas abierto.
Saludos. Dam
Si es lo que necesitas.
