Hello...I have some code that copies different ranges from different worksheets to different slides in a PowerPoint template presentation. It mostly works like a charm. But for whatever reasons, the results are inconsistent. I would say about 20% of the time, all ranges get copied to all slides. However, the rest of the time, some worksheet/slide combos are missed.
And the worst part is it is not always the same combos. Sometimes it is the 3rd and 6th worksheet/slide combo that isn't completed, sometimes it's the just the 9th worksheet/slide, sometimes up to 4 worksheet/slide combos are missed etc. I cannot tell why it is doing this. It's almost like memory or cache or something isn't getting populated or cleared in the background. It's quite frustrating.
Below is the core code. Note that I have 2 rounds of running through the combinations just so my arrays aren't so huge. I have 14 ranges on 11 slides to go through. Any help figuring this out is appreciated.
P.S. Apologies for not using the add-in to paste code
===
Dim myPresentation2 As PowerPoint.Presentation, PowerPointApp2 As PowerPoint.Application
Dim mySlide As Slide, mySlide2 As Slide
Dim shp As Object
Dim MySlideArray As Variant, MyRangeArray As Variant
Dim x As Long, continue As Integer
Dim client As String, acctmgr As String, comment As String, ColumnLetter As String
Dim LRbg As Long, LRnews As Long, LRgoals As Long, LRneeds As Long
Dim LRacct As Long, LRobj As Long, LRmatrix As Long, LCmatrix As Long
Dim LRopp As Long, LRprop As Long, LRexec As Long, LReng As Long, LRcomp As Long
continue = MsgBox("Have you removed all blanks rows from the template?." & _
vbCr & "(If not, they will be copied to the report template)" & vbCr & vbCr & _
"Click Yes to continue or No to abort report generation?", vbYesNo + vbQuestion, "Create Report")
If continue = vbNo Then
MsgBox "Run Report Cancelled.", vbExclamation, "Run Report"
End
Else
MsgBox "This will take a few moments. Please wait...", vbQuestion, "Run Report"
Application.ScreenUpdating = False
'#### Find ranges to each of the adjustable tables...
'Sheets("Key Account Info").Select
LRbg = Cells(Rows.Count, 11).End(xlUp).Row
LRnews = Cells(Rows.Count, 12).End(xlUp).Row
Sheets("Client Objectives").Select
LRgoals = Cells(Rows.Count, 11).End(xlUp).Row
LRneeds = Cells(Rows.Count, 12).End(xlUp).Row
Sheets("Account Team").Select
LRacct = Cells(Rows.Count, 11).End(xlUp).Row
Sheets("Hatch Acct Plan Objectives").Select
LRobj = Cells(Rows.Count, 11).End(xlUp).Row
Sheets("Relationship Matrix").Select
LCmatrix = Cells(2, Columns.Count).End(xlToLeft).Column
LRmatrix = Cells(Rows.Count, LCmatrix).End(xlUp).Row
'Convert To Column Letter
ColumnLetter = Split(Cells(1, LCmatrix - 1).Address, "$")(1)
Columns("B:" & ColumnLetter).EntireColumn.AutoFit
Range("B4").Select
Sheets("Pursuits-Projects").Select
LRopp = Cells(Rows.Count, 11).End(xlUp).Row
LRprop = Cells(Rows.Count, 12).End(xlUp).Row
LRexec = Cells(Rows.Count, 13).End(xlUp).Row
Sheets("Client Engagement").Select
LReng = Cells(Rows.Count, 11).End(xlUp).Row
Sheets("Competitor Info").Select
LRcomp = Cells(Rows.Count, 11).End(xlUp).Row
'#### Turn on / activate PowerPoint...
On Error Resume Next 'Check if PowerPoint is active
Set PowerPointApp2 = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If PowerPointApp2 Is Nothing Then 'Open PowerPoint if not active
MsgBox "PowerPoint is not open, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found on this computer, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If
PowerPointApp2.Visible = True 'Display the PowerPoint presentation
On Error Resume Next 'active presentation: "Account Plan Template"
Set myPresentation2 = PowerPointApp2.Presentations("Account Plan Report Template.pptx")
On Error GoTo 0
If myPresentation2 Is Nothing Then
MsgBox "Template is not open, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If
'#### Assign Client name, Account Manager Name and Matrix Comment to text boxes in PowerPot slides 1 and 8
Set mySlide = myPresentation2.Slides(1)
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
Set mySlide2 = myPresentation2.Slides(8)
mySlide2.Shapes("Comment").TextFrame.TextRange.Text = comment
'#### ROUND 1 copy tables and paste in PowerPoint Slides
'List of PPT Slides to Paste to
MySlideArray = Array(2, 3, 4, 5, 6, 8, 9, 11, 12, 13)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet1.Range("A5:B10"), Sheet1.Range("B13:B" & LRbg - 1), Sheet2.Range("A4:B" & LRgoals - 1), Sheet3.Range("A4:C" & LRacct - 1), _
Sheet4.Range("A4:F" & LRobj - 1), Sheet6.Range("A4:" & ColumnLetter & LRmatrix - 1), _
Sheet7.Range("A4:G" & LRopp - 1), Sheet7.Range("A" & LRprop + 4 & ":F" & LRexec - 1), _
Sheet8.Range("A4:F" & LReng - 1), _
Sheet10.Range("A4:D" & LRcomp - 1))
' Sheet6.Range(Cells(4, 1), Cells(LRmatrix, LCmatrix))
client = Sheet1.Range("B8").Value
acctmgr = Sheet1.Range("B9").Value
comment = Sheet6.Range("A" & LRmatrix + 2).Value
For x = LBound(MySlideArray) To UBound(MySlideArray) 'Loop through Array data
MyRangeArray(x).Copy 'Copy Excel Range
On Error Resume Next 'Paste to PowerPoint and position
Set shp = myPresentation2.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp2.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
With myPresentation2.PageSetup
shp.Left = 100
shp.Top = 140
' shp.Left = (.SlideWidth \ 8) - (shp.Width \ 8)
' shp.Top = (.SlideHeight \ 8) - (shp.Height \ 8)
End With
Set mySlide = myPresentation2.Slides(MySlideArray(x))
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
Next x
'#### ROUND 2 2nd tables (from sheets that have them) and paste in PowerPoint Slides
MySlideArray = Array(2, 3, 4, 10)
MyRangeArray = Array(Sheet1.Range("D12:F20"), Sheet1.Range("B" & LRbg + 1 & ":B" & LRnews - 1), Sheet2.Range("A" & LRgoals + 5 & ":B" & LRneeds - 1), _
Sheet7.Range("A" & LRopp + 4 & ":H" & LRprop - 1))
For x = LBound(MySlideArray) To UBound(MySlideArray) 'Loop through Array data
MyRangeArray(x).Copy 'Copy Excel Range
On Error Resume Next 'Paste to PowerPoint and position
Set shp = myPresentation2.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp2.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
With myPresentation2.PageSetup 'Orient Object
shp.Left = 100
shp.Top = 300
' shp.Left = (.SlideWidth \ 8) - (shp.Width \ 8)
' shp.Top = (.SlideHeight \ 8) - (shp.Height \ 8)
End With
Next x
Set mySlide = myPresentation2.Slides(1)
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
mySlide2.Shapes("Comment").TextFrame.TextRange.Text = comment
'####Save and finish
myPresentation2.SaveAs "Account Plan Report - " & client & ".pptx"
Application.CutCopyMode = False 'Transfer Complete
ThisWorkbook.Activate
Sheets("Key Account Info").Select
Application.ScreenUpdating = True
End If
And the worst part is it is not always the same combos. Sometimes it is the 3rd and 6th worksheet/slide combo that isn't completed, sometimes it's the just the 9th worksheet/slide, sometimes up to 4 worksheet/slide combos are missed etc. I cannot tell why it is doing this. It's almost like memory or cache or something isn't getting populated or cleared in the background. It's quite frustrating.
Below is the core code. Note that I have 2 rounds of running through the combinations just so my arrays aren't so huge. I have 14 ranges on 11 slides to go through. Any help figuring this out is appreciated.
P.S. Apologies for not using the add-in to paste code
===
Dim myPresentation2 As PowerPoint.Presentation, PowerPointApp2 As PowerPoint.Application
Dim mySlide As Slide, mySlide2 As Slide
Dim shp As Object
Dim MySlideArray As Variant, MyRangeArray As Variant
Dim x As Long, continue As Integer
Dim client As String, acctmgr As String, comment As String, ColumnLetter As String
Dim LRbg As Long, LRnews As Long, LRgoals As Long, LRneeds As Long
Dim LRacct As Long, LRobj As Long, LRmatrix As Long, LCmatrix As Long
Dim LRopp As Long, LRprop As Long, LRexec As Long, LReng As Long, LRcomp As Long
continue = MsgBox("Have you removed all blanks rows from the template?." & _
vbCr & "(If not, they will be copied to the report template)" & vbCr & vbCr & _
"Click Yes to continue or No to abort report generation?", vbYesNo + vbQuestion, "Create Report")
If continue = vbNo Then
MsgBox "Run Report Cancelled.", vbExclamation, "Run Report"
End
Else
MsgBox "This will take a few moments. Please wait...", vbQuestion, "Run Report"
Application.ScreenUpdating = False
'#### Find ranges to each of the adjustable tables...
'Sheets("Key Account Info").Select
LRbg = Cells(Rows.Count, 11).End(xlUp).Row
LRnews = Cells(Rows.Count, 12).End(xlUp).Row
Sheets("Client Objectives").Select
LRgoals = Cells(Rows.Count, 11).End(xlUp).Row
LRneeds = Cells(Rows.Count, 12).End(xlUp).Row
Sheets("Account Team").Select
LRacct = Cells(Rows.Count, 11).End(xlUp).Row
Sheets("Hatch Acct Plan Objectives").Select
LRobj = Cells(Rows.Count, 11).End(xlUp).Row
Sheets("Relationship Matrix").Select
LCmatrix = Cells(2, Columns.Count).End(xlToLeft).Column
LRmatrix = Cells(Rows.Count, LCmatrix).End(xlUp).Row
'Convert To Column Letter
ColumnLetter = Split(Cells(1, LCmatrix - 1).Address, "$")(1)
Columns("B:" & ColumnLetter).EntireColumn.AutoFit
Range("B4").Select
Sheets("Pursuits-Projects").Select
LRopp = Cells(Rows.Count, 11).End(xlUp).Row
LRprop = Cells(Rows.Count, 12).End(xlUp).Row
LRexec = Cells(Rows.Count, 13).End(xlUp).Row
Sheets("Client Engagement").Select
LReng = Cells(Rows.Count, 11).End(xlUp).Row
Sheets("Competitor Info").Select
LRcomp = Cells(Rows.Count, 11).End(xlUp).Row
'#### Turn on / activate PowerPoint...
On Error Resume Next 'Check if PowerPoint is active
Set PowerPointApp2 = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If PowerPointApp2 Is Nothing Then 'Open PowerPoint if not active
MsgBox "PowerPoint is not open, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found on this computer, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If
PowerPointApp2.Visible = True 'Display the PowerPoint presentation
On Error Resume Next 'active presentation: "Account Plan Template"
Set myPresentation2 = PowerPointApp2.Presentations("Account Plan Report Template.pptx")
On Error GoTo 0
If myPresentation2 Is Nothing Then
MsgBox "Template is not open, aborting."
Sheets("Key Account Info").Select
Exit Sub
End If
'#### Assign Client name, Account Manager Name and Matrix Comment to text boxes in PowerPot slides 1 and 8
Set mySlide = myPresentation2.Slides(1)
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
Set mySlide2 = myPresentation2.Slides(8)
mySlide2.Shapes("Comment").TextFrame.TextRange.Text = comment
'#### ROUND 1 copy tables and paste in PowerPoint Slides
'List of PPT Slides to Paste to
MySlideArray = Array(2, 3, 4, 5, 6, 8, 9, 11, 12, 13)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet1.Range("A5:B10"), Sheet1.Range("B13:B" & LRbg - 1), Sheet2.Range("A4:B" & LRgoals - 1), Sheet3.Range("A4:C" & LRacct - 1), _
Sheet4.Range("A4:F" & LRobj - 1), Sheet6.Range("A4:" & ColumnLetter & LRmatrix - 1), _
Sheet7.Range("A4:G" & LRopp - 1), Sheet7.Range("A" & LRprop + 4 & ":F" & LRexec - 1), _
Sheet8.Range("A4:F" & LReng - 1), _
Sheet10.Range("A4:D" & LRcomp - 1))
' Sheet6.Range(Cells(4, 1), Cells(LRmatrix, LCmatrix))
client = Sheet1.Range("B8").Value
acctmgr = Sheet1.Range("B9").Value
comment = Sheet6.Range("A" & LRmatrix + 2).Value
For x = LBound(MySlideArray) To UBound(MySlideArray) 'Loop through Array data
MyRangeArray(x).Copy 'Copy Excel Range
On Error Resume Next 'Paste to PowerPoint and position
Set shp = myPresentation2.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp2.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
With myPresentation2.PageSetup
shp.Left = 100
shp.Top = 140
' shp.Left = (.SlideWidth \ 8) - (shp.Width \ 8)
' shp.Top = (.SlideHeight \ 8) - (shp.Height \ 8)
End With
Set mySlide = myPresentation2.Slides(MySlideArray(x))
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
Next x
'#### ROUND 2 2nd tables (from sheets that have them) and paste in PowerPoint Slides
MySlideArray = Array(2, 3, 4, 10)
MyRangeArray = Array(Sheet1.Range("D12:F20"), Sheet1.Range("B" & LRbg + 1 & ":B" & LRnews - 1), Sheet2.Range("A" & LRgoals + 5 & ":B" & LRneeds - 1), _
Sheet7.Range("A" & LRopp + 4 & ":H" & LRprop - 1))
For x = LBound(MySlideArray) To UBound(MySlideArray) 'Loop through Array data
MyRangeArray(x).Copy 'Copy Excel Range
On Error Resume Next 'Paste to PowerPoint and position
Set shp = myPresentation2.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp2.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
With myPresentation2.PageSetup 'Orient Object
shp.Left = 100
shp.Top = 300
' shp.Left = (.SlideWidth \ 8) - (shp.Width \ 8)
' shp.Top = (.SlideHeight \ 8) - (shp.Height \ 8)
End With
Next x
Set mySlide = myPresentation2.Slides(1)
mySlide.Shapes("Client").TextFrame.TextRange.Text = client
mySlide.Shapes("AcctMgr").TextFrame.TextRange.Text = acctmgr
mySlide2.Shapes("Comment").TextFrame.TextRange.Text = comment
'####Save and finish
myPresentation2.SaveAs "Account Plan Report - " & client & ".pptx"
Application.CutCopyMode = False 'Transfer Complete
ThisWorkbook.Activate
Sheets("Key Account Info").Select
Application.ScreenUpdating = True
End If
