VBA range to powerpoint - copy visible cells only? Or copy non-contiguous range?

[Sharn]

Hello,

First-time poster with a rather time-sensitive question. Some coding familiarity, but not specifically with VBA, so I keep tripping on syntax. Been banging my head against this for hours, so any pointers are greatly appreciated!

So I'm trying to export a large table from excel to powerpoint, and trying to split it across multiple slides. I've successfully set up a loop and range definitions that are copied onto each slide. I tried doing this by having each slide's defined range go from the very start (header row) through the end of the section to be displayed in that particular slide. I then select it in excel and hide the intermediary rows (so that out of the selection only the header and the last section are visible). I've tried copying only the visible cells to powerpoint, but instead I keep getting the whole table.

The code is below. Any suggestions?
And on a side note, how do I format the font size of hte resulting powerpoint table?

Thank you! =)


If J = 0 Then 'This is for the first sub-table, and this section works fine
Sheets(SheetName).Range(RangeName).Borders(xlEdgeBottom).LineStyle = xlContinuous
Sheets(SheetName).Range(RangeName).Copy
ppPres.Windows(1).Activate
ppApp.ActiveWindow.View.GotoSlide S_New
'Paste into slide
sld.Shapes.Paste

' Format table in slide - name, size & position
ppApp.ActiveWindow.Selection.ShapeRange.Name = RangeName
ppApp.ActiveWindow.Selection.ShapeRange.Top = T
ppApp.ActiveWindow.Selection.ShapeRange.Left = l
ppApp.ActiveWindow.Selection.ShapeRange.Height = H
ppApp.ActiveWindow.Selection.ShapeRange.Width = W


'ppApp.ActiveWindow.Selection.TextRange.Font.Size = 8



Else ' subsequent subtables - PROBLEM
Rows(J).EntireRow.Hidden = True ' hides middle rows
Sheets(SheetName).Range(RangeName).Borders(xlEdgeBottom).LineStyle = xlContinuous
Sheets(SheetName).Range(RangeName).SpecialCells(xlCellTypeVisible).Copy
ppApp.ActiveWindow.View.GotoSlide S_New
'Spend time to ensure proper clipboard loading/unloading

'Paste into slide
'ppApp.ActiveWindow.View.Paste
sld.Shapes.Paste

Rows(J).EntireRow.Hidden = False
ppApp.ActiveWindow.View.GotoSlide S_New

' Format table in slide - name, size & position ' this works fine
ppApp.ActiveWindow.Selection.ShapeRange.Name = RangeName
ppApp.ActiveWindow.Selection.ShapeRange.Top = T
ppApp.ActiveWindow.Selection.ShapeRange.Left = l
ppApp.ActiveWindow.Selection.ShapeRange.Height = H
ppApp.ActiveWindow.Selection.ShapeRange.Width = W

' OTHER ATTEMPT AT THE FONT SIZE CHANGE THAT DIDN'T WORK

'Change the font of report tables to size 8
Dim m, n As Long
For m = 1 To Range(RangeName).Columns.Count
For n = 1 To Range(RangeName).Rows.Count
With ppApp.ActiveWindow.Selection.TextFrame.TextRange.Font.Size = 8
End With
Next n
Next m

End If ' J=0 vs not

 

[Worf]

Hello and welcome to the Board

I'm going offline now but will work on this tomorrow...

 

[Worf]

Hi
The problem with special cells is that the range is made up of several areas. One way to generate a single range is to use advanced filter. The following example copies 15 rows to each slide:

[FONT=Verdana]Sub Sharn()
[/FONT]Dim ppapp As PowerPoint.Application, pres As PowerPoint.Presentation, _
i%, rn%, j%, k%, sl As Slide, cr As Range
On Error Resume Next
Set ppapp = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then Set ppapp = CreateObject("PowerPoint.Application")
Err.Clear
On Error GoTo 0
ppapp.Visible = msoTrue
ppapp.Presentations.Add
Set pres = ppapp.ActivePresentation
Range("h1") = "Formula"                                                             ' criterion for filter
rn = 1
For i = 1 To 4
    Range("h2").Formula = "=and(row(a2)>" & rn & ",row(a2)<" & (rn + 16) & ")"      ' define range
    rn = rn + 15
    Range("a1").CurrentRegion.AdvancedFilter 2, Range("h1:h2"), Range("k1"), False  ' generate range
    Set sl = pres.Slides.AddSlide(i, pres.SlideMaster.CustomLayouts(1))
    sl.Shapes(1).TextFrame.TextRange.Text = "Slide Title"
    sl.Shapes(1).Top = 5
    sl.Shapes(2).Top = 50
    sl.Shapes(2).TextFrame.TextRange.Text = "SubTitle"
    Set cr = Range("k1").CurrentRegion
    cr.Copy
    sl.Shapes.PasteSpecial ppPasteHTML                                              ' paste table
    For j = 1 To cr.Rows.Count
        For k = 1 To cr.Columns.Count
            With sl.Shapes(3).Table.Cell(j, k).Shape.TextFrame.TextRange.Font       ' format table
                .Color.RGB = RGB(185, 155, 5)
                .Size = 12
            End With
        Next
    Next
Next
End Sub