locked
Error en VBA al pegar un objeto RRS feed

  • 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

    


    martes, 21 de febrero de 2017 18:44