Need help in Macro( Slide 2 Table need to copy on slide 1)

[sksanjeev786]

Hi Team,

The below macro is working fine for me the requirement is to copy the table (content Placeholder 8) from Slide 2 to Slide 1 but with the below macro
Slide 2 Table is copying on Slide 2(Duplicate existing slide 2 table) only instead Slide 1 (and on Slide 1 some image is popping up after generating the macro)

Sub CopyTableWithinPPT()
    Dim sourceSlide As Slide
    Dim destSlide As Slide
    Dim sourceTable As Table
    Dim destTable As Table
    Dim shp As Shape
    Dim newShape As Shape
    
    Set sourceSlide = ActivePresentation.Slides(2)
    Set destSlide = ActivePresentation.Slides(1)
    
    For Each shp In sourceSlide.Shapes
        If shp.Type = msoPlaceholder And shp.Name = "Content Placeholder 8" Then
            If shp.HasTable Then
                Set sourceTable = shp.Table
                Exit For
            End If
        End If
    Next shp
    
    If Not sourceTable Is Nothing Then
        Set newShape = sourceTable.Parent.Duplicate()(1)
        newShape.Top = 100
        newShape.Left = 100
        newShape.Width = sourceTable.Parent.Width
        newShape.Height = sourceTable.Parent.Height
        newShape.LockAspectRatio = msoTrue
        
        destSlide.Shapes.AddShape newShape.Type, newShape.Left, newShape.Top, newShape.Width, newShape.Height
        
        For Each shp In destSlide.Shapes
            If shp.Type = msoTable Then
                Set destTable = shp.Table
                Exit For
            End If
        Next shp
        
        If Not destTable Is Nothing Then
            Dim i As Long
            For i = 1 To sourceTable.Rows.Count
                CopyRow sourceTable.Rows(i), destTable.Rows(i)
            Next i
            
            MsgBox "Table copied successfully from slide 2 to slide 1.", vbInformation
        Else
            MsgBox "Error: Destination table not found.", vbExclamation
        End If
    Else
        MsgBox "Error: Source table not found on slide 2's Content Placeholder 8.", vbExclamation
    End If
End Sub

Sub CopyRow(ByVal sourceRow As Row, ByVal destRow As Row)
    Dim i As Long
    For i = 1 To sourceRow.Cells.Count
        With sourceRow.Cells(i)
            destRow.Cells(i).Shape.TextFrame.TextRange.Text = .Shape.TextFrame.TextRange.Text
            destRow.Cells(i).Shape.TextFrame.TextRange.Font.Color.RGB = .Shape.TextFrame.TextRange.Font.Color.RGB
        End With
    Next i
End Sub

 

[Domenic]

Maybe something like this...

Sub CopyTableWithinPPT()
    Dim sourceSlide As Slide
    Dim destSlide As Slide
    Dim sourceTable As Table
    Dim destTable As Table
    Dim shp As Shape
    Dim i As Long
    
    Set sourceSlide = ActivePresentation.Slides(2)
    Set destSlide = ActivePresentation.Slides(1)
    
    For Each shp In sourceSlide.Shapes
        If shp.Type = msoPlaceholder And shp.Name = "Content Placeholder 8" Then
            If shp.HasTable Then
                Set sourceTable = shp.Table
                Exit For
            End If
        End If
    Next shp
    
    If sourceTable Is Nothing Then
        MsgBox "Error: Source table not found on slide 2's Content Placeholder 8.", vbExclamation
        Exit Sub
    End If
    
    sourceTable.Parent.Copy
    
    destSlide.Shapes.Paste
    
    With destSlide
        With .Shapes(.Shapes.Count)
            .Top = 100
            .Left = 100
            .Width = sourceTable.Parent.Width
            .Height = sourceTable.Parent.Height
            .LockAspectRatio = msoTrue
            Set destTable = .Table
        End With
    End With
    
    For i = 1 To sourceTable.Rows.Count
        CopyRow sourceTable.Rows(i), destTable.Rows(i)
    Next i
    
    MsgBox "Table copied successfully from slide 2 to slide 1.", vbInformation

End Sub

Hope this hleps!

 

[sksanjeev786]

Maybe something like this...

Sub CopyTableWithinPPT()
    Dim sourceSlide As Slide
    Dim destSlide As Slide
    Dim sourceTable As Table
    Dim destTable As Table
    Dim shp As Shape
    Dim i As Long
   
    Set sourceSlide = ActivePresentation.Slides(2)
    Set destSlide = ActivePresentation.Slides(1)
   
    For Each shp In sourceSlide.Shapes
        If shp.Type = msoPlaceholder And shp.Name = "Content Placeholder 8" Then
            If shp.HasTable Then
                Set sourceTable = shp.Table
                Exit For
            End If
        End If
    Next shp
   
    If sourceTable Is Nothing Then
        MsgBox "Error: Source table not found on slide 2's Content Placeholder 8.", vbExclamation
        Exit Sub
    End If
   
    sourceTable.Parent.Copy
   
    destSlide.Shapes.Paste
   
    With destSlide
        With .Shapes(.Shapes.Count)
            .Top = 100
            .Left = 100
            .Width = sourceTable.Parent.Width
            .Height = sourceTable.Parent.Height
            .LockAspectRatio = msoTrue
            Set destTable = .Table
        End With
    End With
   
    For i = 1 To sourceTable.Rows.Count
        CopyRow sourceTable.Rows(i), destTable.Rows(i)
    Next i
   
    MsgBox "Table copied successfully from slide 2 to slide 1.", vbInformation

End Sub

Hope this hleps!

Hello Sir,

I have tried with the above Macro and it is showing error while running the macro.
Please see the screenshot mentioned below

 

[Domenic]

You also need to include your procedure CopyRow(), as you did in your original post . . .

Sub CopyRow(ByVal sourceRow As Row, ByVal destRow As Row)
    Dim i As Long
    For i = 1 To sourceRow.Cells.Count
        With sourceRow.Cells(i)
            destRow.Cells(i).Shape.TextFrame.TextRange.Text = .Shape.TextFrame.TextRange.Text
            destRow.Cells(i).Shape.TextFrame.TextRange.Font.Color.RGB = .Shape.TextFrame.TextRange.Font.Color.RGB
        End With
    Next i
End Sub

 

[sksanjeev786]

You also need to include your procedure CopyRow(), as you did in your original post . . .

Sub CopyRow(ByVal sourceRow As Row, ByVal destRow As Row)
    Dim i As Long
    For i = 1 To sourceRow.Cells.Count
        With sourceRow.Cells(i)
            destRow.Cells(i).Shape.TextFrame.TextRange.Text = .Shape.TextFrame.TextRange.Text
            destRow.Cells(i).Shape.TextFrame.TextRange.Font.Color.RGB = .Shape.TextFrame.TextRange.Font.Color.RGB
        End With
    Next i
End Sub

Sure! thank you so much! for your help on this....

 

[Domenic]

You're very welcome, glad I could help.

Cheers!