CODEWITHSUNDEEP
excelvbapowerpoint
OliAK
OliAK

Reputation: 73

Pasting Text from Ranges as OLEObject using for loop

I am pasting a table from excel to power point as OLEObject (See Picture 1). I converted the table into range because I merged the same date values. Until now I can only paste sorted table with merged cells. 

Sub TableData()
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim slds As PowerPoint.Slides
Dim sld, sld1, sld2 As PowerPoint.slide
Dim r As Range
Dim lastRw As Long
Dim pptextbox As PowerPoint.Shape
Dim oLayout As CustomLayout
Application.DisplayAlerts = False     

lastRw = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

With ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
Set r = .Range
.Unlist ' convert the table back to a range
End With

ThisWorkbook.Worksheets("Sheet1").Range("B2:B" & lastRw).Select

MergeCells:

For Each r In Selection
    If r.Value = r.Offset(1, 0).Value And r.Value <> "" Then
        Range(r, r.Offset(1, 0)).Merge
        Range(r, r.Offset(1, 0)).HorizontalAlignment = xlCenter
        Range(r, r.Offset(1, 0)).VerticalAlignment = xlCenter
        GoTo MergeCells
    End If
Next
        Set ppt = CreateObject("PowerPoint.Application")
        Set sld1 = ppt.ActivePresentation.Slides.Add(ppt.ActivePresentation.Slides.Count + 1, ppLayoutBlank)

        set r=ThisWorkbook.Worksheets("Sheet1").Range("A:B" & lastRw)
        r.copy
        sld1.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
End Sub

Picture 1

Now I want to paste the value of first column corresponding to the every specific date as OLEObject separately (See Picture 2) besides the table.

Picture 2 I am trying to paste it as OLEObject, because I would like to use the conditional formatting that I have used in the excel. From my understanding, I require to run a for loop. However, as I merged the second column, I don't know how to deal it. I will highly appreciate your suggestions/Solutions. Regard, Oliver

Upvotes: 0

Views: 93

Answers (1)

OliAK
OliAK

Reputation: 73

Dealing with merged cell is always problematic. Therefore, before merging the cells auto filter should be applied one by one using a dynamic array. Then a For loop can be applied for each filtered result to paste it separately in PPT slide. 

Sub TableData()
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim slds As PowerPoint.Slides
Dim sld, sld1, sld2 As PowerPoint.slide
Dim r As Range
Dim lastRw, lastRw1 As Long
Dim pptextbox As PowerPoint.Shape
Dim oLayout As CustomLayout
Application.DisplayAlerts = False

'Here column 'D' contains only unique dates   
lastRw = Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row

Dim list() As Variant

ReDim list(2 To lastRw)

Dim i, j As Byte


For i = 2 To lastRw


        list(i) = Cells(i, 4).Value


Next i

lastRw1 = Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row
Set ppt = CreateObject("PowerPoint.Application")
Set sld1 = ppt.ActivePresentation.Slides.Add(ppt.ActivePresentation.Slides.Count + 1, 
 ppLayoutBlank)
For j = LBound(list) To UBound(list)


ActiveSheet.Range("A2:C" & lastRw1).AutoFilter Field:=2, Criteria1:= _
list(j)
lastRw1 = Sheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row

Set r = ThisWorkbook.Worksheets("Sheet1").Range("$A$2:A" & lastRw1)
        r.Copy

sld1.Shapes.PasteSpecial DataType:=ppPasteRTF, Link:=msoFalse

'Defining the position of the Text box          
If j < 10 Then

sld1.Shapes(j - 1).Top = 5
sld1.Shapes(j - 1).Left = 5 + (j - 1) * 100

Else

sld1.Shapes(j - 1).Top = 300
sld1.Shapes(j - 1).Left = 5 + (j - 9) * 100


End If
Next j
Sheet1.ShowAllData
End Sub

Upvotes: 1

Related Questions