With this i have only put the "y" next to the "Lorem Ipsum 1" row for it to bring in that detail.
Hope this helpsSub pp() Dim ppSl As PowerPoint.Slide Dim strPath As String Dim rCell As Range, x As Long strPath = "C:\Users\A\Desktop\Detailed Findings_VBA.pptx" '< your template location Set oPPTApp = CreateObject("PowerPoint.Application") oPPTApp.Visible = msoTrue Set oPPTFile = oPPTApp.Presentations.Open(strPath) Set ppSl = oPPTFile.Slides(1) With Sheet1 For Each rCell In .Range("C2:C" & .Range("B" & Rows.Count).End(xlUp).Row).Cells If rCell.Value = "y" Then x = x + 1 Select Case x Case 1 With ppSl.Shapes("Group 40") .GroupItems(1).TextFrame.TextRange.Text = rCell.Offset(0, -1).Value .GroupItems(2).TextFrame.TextRange.Text = rCell.Offset(1, -1).Value .GroupItems(3).TextFrame.TextRange.Text = rCell.Offset(2, -1).Value End With Case 2 With ppSl.Shapes("Group 41") .GroupItems(1).TextFrame.TextRange.Text = rCell.Offset(0, -1).Value .GroupItems(2).TextFrame.TextRange.Text = rCell.Offset(1, -1).Value .GroupItems(3).TextFrame.TextRange.Text = rCell.Offset(2, -1).Value End With Case 3 With ppSl.Shapes("Group 42") .GroupItems(1).TextFrame.TextRange.Text = rCell.Offset(0, -1).Value .GroupItems(2).TextFrame.TextRange.Text = rCell.Offset(1, -1).Value .GroupItems(3).TextFrame.TextRange.Text = rCell.Offset(2, -1).Value End With Case 4 With ppSl.Shapes("Group 43") .GroupItems(1).TextFrame.TextRange.Text = rCell.Offset(0, -1).Value .GroupItems(2).TextFrame.TextRange.Text = rCell.Offset(1, -1).Value .GroupItems(3).TextFrame.TextRange.Text = rCell.Offset(2, -1).Value End With End Select End If Next rCell End With With oPPTFile .SaveAs "C:\Users\A\Desktop\Detailed Findings_VBA_Edited.pptx" .Close End With oPPTApp.Quit Set oPPTApp = Nothing Set oPPTFile = Nothing End Sub




Reply With Quote