vba copy paste from excel to power point

[ziad alsayed]

good day

i have 3 sheets in my excel workbook, each contain a table only ( not insert table), i need a vba code that will loop through the sheets and copy ( let say from A1 to E16) and paste it in power point ( the result should not be as Picture) , the slide layout should be "title and content.

now after pasting in powerpoint the code should do the below in powerpoint ( it is ok by my if we also add a power point code to do it).
go to table tools choose design
1- check the box of banded row
2- check the box of total row
3- check the box of hear row
4- check the box of first column.
5- choose the table medium style accent 1
6- go to effect ,cell bevel, choose riblet

Summary : i have 3 sheets in excel , i should have 3 slides in power point.
<jarootja>hope you can assist thanks in advance.</jarootja>

 

[Worf]

Good evening

Please test the code below. You may need to add a reference to Microsoft PowerPoint at the VBE/Tools/References.
I'm running out of time now, so I'll post the formatting part tomorrow.

Sub PP_Tables()
    Dim objPres As Object, ws As Worksheet, objPPT As Object, tb As Object, i%, j%, k%, _
    ns%, LS As PowerPoint.Slide
            
    Set objPPT = CreateObject("Powerpoint.Application")
    objPPT.Visible = True
    Set objPres = objPPT.presentations.Open(ThisWorkbook.Path & "\Ziad.ppt")
    For k = 1 To 3
        ns = objPres.Slides.Count
        objPres.Slides.Add Index:=ns + 1, Layout:=ppLayoutTitle
        objPres.Slides(ns).Shapes.AddTable 16, 5, 10, 10
        Set ws = ThisWorkbook.Worksheets(k)
        Set LS = objPres.Slides(ns)
        Set tb = LS.Shapes(LS.Shapes.Count).Table
        For i = 1 To 16
           For j = 1 To 5
                tb.cell(i, j).Shape.TextFrame.TextRange.Text = ws.Cells(i, j).Value
            Next
        Next
    Next
    objPres.Save
    objPres.Close
    Set objPres = Nothing
    Set objPPT = Nothing
End Sub

 

[ziad alsayed]

Dear Worf
merry Christmas and happy new year.
thanks for answering at this time.
it is working.i have some comments but maybe after you send the formatting i will not have them, i will wait till you send the formatting.
thanks again.

 

[ziad alsayed]

dear Worf

i am on my way to the airport , i may not be able to recheck the post today . below are my comments

• My sheets are not identical ( which I did not mention in my first post , sorry about that), so the tables in the power point will not have the same number of and rows. In cell A1 and for all sheets I have the titles which should appear in the title area in the power point slide.
• From Cell A2 ( down and to the right ) I have my data, which is not identical for all sheets(I mean not the same number of rows and columns but all data starts from A2), these data should appear in the content area in the power point slide. I think this should be done by determining the number of rows and columns ( without the first row) and replace it instead of 16 and 5 In the code.
• Some of my data are percentages like 25% and it is appearing in power point as 0.25 ( this after I run the code you sent).
• The numbers in my data are formatted with comma style and decrease decimal, after running your code it is not appearing like that.
• In your code and after 16, 5 ( I think it is number of rows and columns) what is the 10, 10 ??

thanks again ans appreciate your effort and assistance.

 

[Worf]

Hello Ziad
Please test this new version, tested with Office 2010.

• It’s not possible to add a bevel with VBA, at least using Excel 2010. See this thread:

Table cells and ThreeD property? - Microsoft Community

• If the numbers don’t format correctly at the slides, I’ll need you to inform me the exact formatting strings that you used at the Excel sheets.
• You asked about AddTable parameters, PowerPoint Help has detailed explanation on that.
• Any other problems, just point them out.

Sub PP_Tables()
    Dim objPres As Object, ws As Worksheet, objPPT As Object, tb As Object, i%, j%, k%, _
    ns%, LS As PowerPoint.Slide, ttop%, rng As Range, temp
                
    Set objPPT = CreateObject("Powerpoint.Application")
    objPPT.Visible = True
    Set objPres = objPPT.presentations.Open(ThisWorkbook.Path & "\Ziad.pptx")
    
    For k = 1 To 3
        Set ws = ThisWorkbook.Worksheets(k)
        ns = objPres.Slides.Count
        Set LS = objPres.Slides(ns)
        objPres.Slides.Add Index:=ns + 1, Layout:=ppLayoutTitle
        With LS.Shapes.Title
            .Top = 5
            .TextFrame.TextRange.Text = ws.Cells(1, 1).Value
            .Height = objPres.PageSetup.SlideHeight / 10
            ttop = .Height + 10
            
        End With
                
        Set rng = ws.Range("a2").CurrentRegion
        Set rng = Range(rng.Cells(2, rng.Columns(1).Column), rng(rng.Rows.Count, rng.Columns.Count))
        
        objPres.Slides(ns).Shapes.AddTable rng.Rows.Count, rng.Columns.Count, 5, ttop, _
        objPres.PageSetup.SlideWidth - 10, objPres.PageSetup.SlideHeight - ttop
                
        Set tb = LS.Shapes(LS.Shapes.Count).Table
        For i = 1 To rng.Rows.Count
            For j = 1 To rng.Columns.Count
                Select Case rng.Cells(i, j).NumberFormat
                    Case "0%", "0.00%", "0.0%"              ' percent formats
                        temp = Strings.FormatPercent(rng.Cells(i, j).Value, 1)
                    Case "0.0"                              ' number format
                        temp = Strings.FormatNumber(rng.Cells(i, j).Value, 1)
                    Case Else
                        temp = rng.Cells(i, j).Value
                End Select
                tb.cell(i, j).Shape.TextFrame.TextRange.Text = CStr(temp)
                    
            Next
        Next
    With tb
        .ApplyStyle "{B301B821-A1FF-4177-AEE7-76D212191A09}", False
        .HorizBanding = True
        .FirstCol = True
        .FirstRow = True
        .LastRow = True
    End With
    Next
        
    objPres.SaveAs ThisWorkbook.Path & "\Ziadnew.pptx"
    objPres.Close
    Set objPres = Nothing
    Set objPPT = Nothing
End Sub

 

[ziad alsayed]

dear Worf

your code worked perfectly. i really appreciate you effort and assistance.
percentages are ok.
still need the below
as for numbers, below is the number format i need
_(* #,##0_);_(* (#,##0);_(* "-"??_);_(@_)

if the number or percentage is negative i want it to be in red and underlined.

please note that numbers and percentages are not centered in the table, need them to be centered.

thanks again,

 

[Worf]

Hello
Please test this new version, to be executed from Excel, as before.

Option Explicit
Dim tb As Object


Sub PP_Tables()
    Dim objPres As Object, ws As Worksheet, objPPT As Object, i%, j%, k%, _
    ns%, LS As PowerPoint.Slide, ttop%, rng As Range, temp, cv
                
    Set objPPT = CreateObject("Powerpoint.Application")
    objPPT.Visible = True
    Set objPres = objPPT.Presentations.Open(ThisWorkbook.Path & "\Ziad.pptx")
    
    For k = 1 To 3
        Set ws = ThisWorkbook.Worksheets(k)
        ns = objPres.Slides.Count
        Set LS = objPres.Slides(ns)
        objPres.Slides.Add Index:=ns + 1, Layout:=ppLayoutTitle
        With LS.Shapes.Title
            .Top = 5
            .TextFrame.TextRange.Text = ws.Cells(1, 1).Value
            .Height = objPres.PageSetup.SlideHeight / 10
            ttop = .Height + 10
        End With
                
        Set rng = ws.Range("a2").CurrentRegion
        Set rng = Range(rng.Cells(2, rng.Columns(1).Column), rng(rng.Rows.Count, rng.Columns.Count))
        objPres.Slides(ns).Shapes.AddTable rng.Rows.Count, rng.Columns.Count, 5, ttop, _
        objPres.PageSetup.SlideWidth - 10, objPres.PageSetup.SlideHeight - ttop
                
        Set tb = LS.Shapes(LS.Shapes.Count).Table
        With tb
            .ApplyStyle "{B301B821-A1FF-4177-AEE7-76D212191A09}", False
            .HorizBanding = True:        .FirstCol = True
            .FirstRow = True:           .LastRow = True
        End With
        For i = 1 To rng.Rows.Count
            For j = 1 To rng.Columns.Count
                tb.Cell(i, j).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
                cv = rng.Cells(i, j).Value
                Select Case rng.Cells(i, j).NumberFormat
                    
                    Case "0%", "0.00%", "0.0%"              ' percent formats
                        temp = Strings.FormatPercent(cv, 1)
                        If CSng(cv) < 0 Then NegVal i, j
                    Case Else
                        If Not IsNumeric(cv) Then
                            temp = cv
                        Else
                            Select Case cv
                                Case Is = 0
                                    temp = "-"
                                Case Else
                                    temp = Strings.FormatNumber(cv, 2, vbFalse, vbTrue, vbFalse)
                                    If CSng(temp) < 0 Then NegVal i, j
                            End Select
                        End If
                End Select
                tb.Cell(i, j).Shape.TextFrame.TextRange.Text = CStr(temp)
            Next
        Next
    Next
        
    objPres.SaveAs ThisWorkbook.Path & "\Ziadnew.pptx"
    objPres.Close
    Set objPres = Nothing
    Set objPPT = Nothing
End Sub


Sub NegVal(a%, b%)
    With tb.Cell(a, b).Shape.TextFrame.TextRange.Font
        .Underline = msoTrue
        .Color.RGB = RGB(250, 1, 1)
    End With
End Sub

 

[ziad alsayed]

dear worf,

the negative is working , as for numbers ( the comma is not appearing and i am receiving 2 decimal) , need the comma to appear and to round up the number.

e.g : 8540588.9224289 should appear as 8,540,589

thanks in advance.

 

[Worf]

Hello
The FormatNumber function will use the delimiting character defined at Windows/Control Panel/Regional Settings. If your system is not yet using a comma, you should change that.
I changed only one line of code:

                            Select Case cv
                                Case Is = 0
                                    temp = "-"
                                Case Else
[COLOR=#ffa500]                                    temp = Strings.FormatNumber(cv, 0, vbFalse, vbTrue, vbUseDefault)[/COLOR]
                                    If CSng(temp) < 0 Then NegVal i, j
                            End Select

 

[ziad alsayed]

dear worf

now it is working perfectly with no comment.

thanks for yoour effort .