Copying filtered cells to powerpoint table - excel

Question

Im relatively new to VBA. Im currently trying to run a code that copies filtered visible cells into powerpoint as a table. The dataset is rather huge and will continue to grow. How do I make the code dynamic and format the table that's being pasted into powerpoint?
Im getting an error Run time error '-2147188160 (80048240)': Shapes(unknown member) : Integer out of range. 2795 is not in the valid range of 1 to 75"
I would also like the data set to be formatted whereby the first and second column thats copied from the excel sheet gets transposed as the column headers in ppt.
The table looks like this in excel:
Product Code
Product Name
Keyword
Country
Status
Description
123456
Kobe Chicken
Chicken
Japan
Imported
NIL
643734
Hanwook Beef
Beef
Korea
Exported
NIL
The format i'd like in ppt:
123456 Kobe Chicken
643734 Hanwook Beef
(If the products list go on the products would be added via columns)
Country
Japan
Korea
NIL
Status
Imported
Exported
NIL
Description
NIL
NIL
Below is my code:
Also, is there anyway I can get the user to select from the dropdown menu of keyword to set the filtering criterea rather than entering it as a userinput for the code to filter out cells that match the criterea?
Sub Export_Range()
Dim userin As Variant
Dim userin2 As Variant
Dim pp As New PowerPoint.Application
Dim ppt As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shpTable As PowerPoint.Shape
Dim i As Long, j As Long
Dim rng As Excel.Range
Dim sht As Excel.Worksheet
'To set range
userin = InputBox("Please enter the product you'd like to filter by: ")
userin2 = InputBox("Yes or No?: ")
set rng = Range("B$16:$AG$2810").Select
Selection.AutoFilter
ActiveSheet.Range("$B$16:$AG$2810").AutoFilter Field:=3, Criteria1:=userin
ActiveSheet.Range("$B$16:$AG$2810").AutoFilter Field:=4, Criteria1:=userin2
'This hides columns that are not needed in copying to ppt
Range("E16").EntireColumn.Hidden = True
Range("G16").EntireColumn.Hidden = True
Range("H16").EntireColumn.Hidden = True
Range("J16").EntireColumn.Hidden = True
Range("M16").EntireColumn.Hidden = True
Range("O16").EntireColumn.Hidden = True
Range("P16").EntireColumn.Hidden = True
Range("Q16").EntireColumn.Hidden = True
'Creates new ppt, and adds selected info into table
pp.Visible = True
If pp.Presentations.Count = 0 Then
Set ppt = pp.Presentations.Add
Else
Set ppt = pp.ActivePresentation
End If
Set sld = ppt.Slides.Add(1, ppLayoutTitleOnly)
Set shpTable = sld.Shapes.AddTable(rng.Rows.Count, rng.Columns.Count)
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
shpTable.Table.Cell(i, j).Shape.TextFrame.TextRange.Text = _
rng.Cells(i, j).Text
Next
Next
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
If (rng.Cells(i, j).MergeArea.Cells.Count > 1) And _
(rng.Cells(i, j).Text <> "") Then
shpTable.Table.Cell(i, j).Merge _
shpTable.Table.Cell(i + rng.Cells(i, j).MergeArea.Rows.Count - 1, _
j + rng.Cells(i, j).MergeArea.Columns.Count - 1)
End If
Next
Next
sld.Shapes.Title.TextFrame.TextRange.Text = _
rng.Worksheet.Name & " - " & rng.Address
End Sub

Answer 1

Here's an example of how to do this. I'm not sure if you simplfied your actual use case but I used this table for testing:
End Result:
Code:
Sub Tester()
'Add project reference to `Microsoft PowerPoint xx.x Object Library`
Dim loProds As ListObject, rngVis As Range, colKeyWord As ListColumn
Dim c As Range, rw As Range, visCount As Long, col As Long
Dim ppApp As PowerPoint.Application, ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide, pptable As PowerPoint.Table
Dim indxProdCode As Long, indxProdName As Long
Dim indxCountry As Long, indxStatus As Long, indxDescr As Long
'info is in listobject "Products" on worksheet "Listing"
Set loProds = ThisWorkbook.Worksheets("Listing").ListObjects("Products")
'filter on Keyword = "Beef"
loProds.ShowAutoFilter = True
Set colKeyWord = loProds.ListColumns("Keyword")
loProds.Range.AutoFilter Field:=colKeyWord.Index, Criteria1:="Beef"
'get visible cells in keyword column
On Error Resume Next 'ignore error if no visible cells
Set rngVis = colKeyWord.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0 'stop ignoring errors
If rngVis Is Nothing Then 'no rows left after filtering?
MsgBox "No rows visible after applying filter...", vbExclamation
Exit Sub
End If
visCount = rngVis.Cells.Count 'how many visible rows left?
'start PPT, add a new presentation, and put a table on slide 1
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
Set ppPres = ppApp.Presentations.Add()
Set ppSlide = ppPres.Slides.Add(1, ppLayoutTitleOnly)
Set pptable = ppSlide.Shapes.AddTable(4, visCount + 1).Table
SetText pptable.cell(2, 1), "Country" 'fixed row headers in column 1
SetText pptable.cell(3, 1), "Status"
SetText pptable.cell(4, 1), "Description"
'find the column indexes of the content we want to extract from `loProds`
indxProdCode = loProds.ListColumns("Product Code").Index
indxProdName = loProds.ListColumns("Product Name").Index
indxCountry = loProds.ListColumns("Country").Index
indxStatus = loProds.ListColumns("Status").Index
indxDescr = loProds.ListColumns("Description").Index
col = 1
'loop over each visible row and populate a new column in the table
For Each c In rngVis.Cells
Set rw = Application.Intersect(c.EntireRow, loProds.DataBodyRange) 'the table row for this cell
col = col + 1 'next ppt table column
SetText pptable.cell(1, col), rw.Cells(indxProdCode).Value & " " & rw.Cells(indxProdName).Value
SetText pptable.cell(2, col), rw.Cells(indxCountry).Value
SetText pptable.cell(3, col), rw.Cells(indxStatus).Value
SetText pptable.cell(4, col), rw.Cells(indxDescr).Value
Next c
End Sub
'helper method for setting table cell text
Sub SetText(cell As PowerPoint.cell, v)
cell.Shape.TextFrame.TextRange.Text = v
End Sub