Error en VBA al pegar un objeto
Pregunta
-
Que tal,
He estado trabajando con una macro para exportar tablas de Excel a PowerPoint, sin embargo no logro encotrar solución para el error que envío en las imagenes, cuando ejecuto la macro, se detiene en cualquier tabla desde la primera hasta la última del total y no logra terminar, ¿Alguna sugerencia?, de antemano gracias
La macro que utilizo es la siguiente:
Sub ExportarAPowerPoint()
' Crea un documento de Power Point y crea la presentación
' incluyendo las tablas que se seleccionaron para el documento
' https://www.thespreadsheetguru.com/the-code-vault/2014/2/22/create-a-shape-or-text-box-and-format-it
Dim nombre As String
Application.DisplayAlerts = False
' De la tabla de Reportes
Dim a As Integer
Dim b As Integer
'----pp
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 i As Integer
Dim diapositiva As Integer
b = ultimaFila("Reportes", "E")
diapositiva = 1
'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
' Portada
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = ppSlideSizeLetterPaper
pptPres.PageSetup.SlideOrientation = msoOrientationHorizontal
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
' Elementos y Formato de portada
With pptSlide.Shapes.AddShape(msoShapeRectangle, 0, 0, 720, 110)
.Fill.ForeColor.RGB = RGB(107, 107, 107)
.Line.Visible = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
.TextFrame.TextRange.Characters.Text = "*"
.TextFrame2.TextRange.Font.Size = 20
.TextFrame2.TextRange.Font.Name = "Calibri Light"
End With
With pptSlide.Shapes.AddShape(msoShapeRectangle, 0, 110, 720, 5)
.Fill.ForeColor.RGB = RGB(255, 195, 0)
.Line.Visible = msoFalse
End With
With pptSlide.Shapes.AddShape(msoShapeRectangle, 350, 250, 250, 25)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.Visible = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Characters.Text = "Informe de Resultados"
.TextFrame2.TextRange.Font.Size = 25
.TextFrame2.TextRange.Font.Name = "Calibri Light"
End With
With pptSlide.Shapes.AddShape(msoShapeRectangle, 350, 275, 250, 15)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.Visible = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
.TextFrame.TextRange.Characters.Text = "Fecha de Actualización: " & Date$
.TextFrame2.TextRange.Font.Size = 12
.TextFrame2.TextRange.Font.Name = "Calibri Light"
End With
With pptSlide.Shapes.AddShape(msoShapeRectangle, 0, 500, 720, 15)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.Visible = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.TextRange.Characters.Text = "*"
.TextFrame2.TextRange.Font.Size = 10
.TextFrame2.TextRange.Font.Name = "Calibri Light"
End With
For a = 2 To b
If Sheets("Reportes").Cells(a, 4) = 1 Then
nombre = Sheets("Reportes").Cells(a, 5)
' Si existe la hoja para el reporte
If ExisteHoja(nombre) = True Then
' Indicador de diapositivas en la presentación
diapositiva = diapositiva + 1
' Agregar las subsecuenteas diapositivas
Set pptSlide = pptPres.Slides.Add(diapositiva, ppLayoutBlank)
' Elementos y Formato
With pptSlide.Shapes.AddShape(msoShapeRectangle, 0, 0, 720, 50)
.Fill.ForeColor.RGB = RGB(107, 107, 107)
.Line.Visible = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
.TextFrame.TextRange.Characters.Text = "Reporte de Resultados"
.TextFrame2.TextRange.Font.Size = 16
.TextFrame2.TextRange.Font.Name = "Calibri Light"
End With
With pptSlide.Shapes.AddShape(msoShapeRectangle, 0, 50, 720, 2)
.Fill.ForeColor.RGB = RGB(255, 195, 0)
.Line.Visible = msoFalse
End With
'Copiar la tabla de Excel
Sheets(nombre).Select
Set excelTable = Sheets(nombre).Range(Cells(1, 1), Cells(ultimaFila(nombre, "A"), ultimaColumna(nombre, ultimaFila(nombre, "A"))))
excelTable.Copy
'Pegar la tabla de Excel en PowerPoint y centrarla en la diapositiva
pptSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
'pptSlide.Shapes.PasteSpecial ppPasteMetafilePicture
'pptSlide.Shapes.Paste
Application.CutCopyMode = False
'pptApp.ActiveWindow.Selection.ShapeRange.Left = cm2Points(1)
'pptApp.ActiveWindow.Selection.ShapeRange.Top = cm2Points(2)
'pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'--- pp
End If
End If
Next
End Sub
- Editado Victor German F martes, 21 de febrero de 2017 18:46
