VBA update existing PPT charts from Excel - too much memory? - excel

Question

I have searched for months to find an answer to my problem and think I'm close, but not sure how to rectify it. All my VBA knowledge comes from Google, Stack Overflow, & various forums so please excuse the state of my code.
Overall goal:
I have a PPT template file containing 1 template slide that has several charts full of "dummy" data, formatted exactly how I need it. I also have an Excel master file containing data on a particular sheet (also contains the VBA). I need to duplicate the template slide for numNames data rows, then on each slide populate the charts (and other items) with the real data contained in each row.
The issues:
Very low reliability of this code at scale. This code works well with numNames < ~15. If I have more rows of data/slides to populate, the code fails.
Sometimes graphs will "disappear" after populating with data leading to errors in later subs. This can happen to any of the circular graphs on any slide. I added .Refresh and .DoEvents to fix this, to no avail. Missing Graph
PPT sucks up a ton of available memory if I populate the charts too quickly which I think contributes to some of my headaches (hence the Application.Wait). I am using a work laptop running 64 bit Excel/PPT with approx 4GB RAM available at most times. Peak PPT memory usage ~1.3GB while inside loop. Not sure what is going on here.
I have tried Application.ScreenUpdating = false and it helps a bit, but the issues above still occur.
I believe all of my problems stem from how I'm populating these graphs with the real data, but so far I have not found any better solutions. I am looking for any advice on how to populate these graphs in a better/quicker way, or generally clean up this code so that it runs more smoothly. Thanks.
If you want to skip the setup portion of this sub, just ctrl+F '$
*some code here is not my own, not taking credit for any code I did not personally write
Option Explicit
'Excel
Public ProjectName As String
Public NewCtrlFileExists As String
Public wb As Workbook
Public ctrl As Worksheet
Public xData As Worksheet
Public iHeaders As Integer
Public numNames As Integer
Public FirstRow As Integer
Public LastRow As Integer
Public LastCol As Integer
'Powerpoint
Public myPres As PowerPoint.Presentation
'Error handling
Public errArea As String
Public g_objFSO As Scripting.FileSystemObject
Public g_scrText As Scripting.TextStream
Public Msg, Style, Response
Sub CreateDashboards()
'1. Add PPT refs to Excel: Tools > References > Microsoft PowerPoint
'2. Add error logging: Tools > References > Microsoft Scripting Runtime
iHeaders = 0
numNames = 0
FirstRow = 0
LastRow = 0
LastCol = 0
On Error GoTo Failure
Startup:
errArea = "Startup"
Set wb = Excel.Application.ActiveWorkbook
Sheet1.Activate 'Control sheet
Set ctrl = wb.ActiveSheet
'File names
ProjectName = ctrl.Range("ProjectName") 'project name
Dim PptTemplateName As String
PptTemplateName = ctrl.Range("PptTemplateName") 'template name
'Get data
Sheet2.Activate 'Data
Set xData = wb.ActiveSheet
iHeaders = 2
FirstRow = iHeaders + 1
LastRow = xData.UsedRange.Rows.Count
LastCol = xData.UsedRange.Columns.Count
numNames = LastRow - iHeaders
Initialize:
errArea = "Initialize"
ctrl.Range("PptReportName") = ProjectName 'PptReportName: default is project name, but also user-defined if desired
'Round and clean data
Call CleanData
'get E chart data
Dim rngEcols As Range
Set rngEcols = xData.Range("1:1")
Dim iEcount As Integer, lEstartCol As Integer, lEendCol As Integer
iEcount = Excel.Application.CountIf(rngEcols, "E")
lEstartCol = WorksheetFunction.Match("E", rngEcols, 0)
lEendCol = lEstartCol + iEcount - 1
'get max value for all E chart data
Dim dEmaxvalue As Single 'decimal
Dim dEAxisMax As Single 'decimal
dEmaxvalue = Application.Max(xData.Range(Cells(iHeaders + 1, lEstartCol), Cells(LastRow, lEendCol)))
'define the axis max as dEmaxvalue rounded up to nearest 10%, then add 5%
dEAxisMax = Application.RoundUp(dEmaxvalue, 1) + 0.05
'get attribute label positions
Dim lEstart, lEend
Set lEstart = xData.Cells((FirstRow - 1), lEstartCol)
Set lEend = xData.Cells((FirstRow - 1), lEendCol)
'get PPT
Set myPres = GetOpenOrClosedPPT(wb.Path & "\" & PptTemplateName & ".pptx")
myPres.Windows(1).Activate
'transpose attribute labels into PPT E chart
With myPres.Slides(1).Shapes("E").Chart
.ChartData.Workbook.Sheets(1).Range("A2:" & Cells(iEcount + 1, 1).Address & "") _
= Excel.Application.Transpose(xData.Range("" & lEstart.Address & ":" & lEend.Address & ""))
Dim rngEdata As Range 'get E data range
Set rngEdata = Range("A1:" & Cells(iEcount + 1, 2).Address & "")
Dim sEchartsource As String
sEchartsource = "='Sheet1'!" & rngEdata.Address & "" 'set chart data source to E data range
.SetSourceData Source:=sEchartsource
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dEAxisMax
End With
Execute:
errArea = "Execute"
'create slide for each row of data
Dim i As Long
For i = 1 To numNames - 1 'template slide already exists
myPres.Slides(1).Duplicate
Next i
'populate slides with data
Dim lDataRow As Integer, lSldNum As Integer
lSldNum = 1
lDataRow = lSldNum + iHeaders 'account for headers
Dim Slide As Slide
Dim y As Integer
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$$$ Begin populate chart data $$$$$$$$$$$$$$$$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
For Each Slide In myPres.Slides
errArea = "Slide " & lSldNum
myPres.Slides(lSldNum).Select
With myPres.Slides(lSldNum)
With .Shapes("B").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 5) * 100
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("C").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 6) * 100
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("E").Chart
For y = 1 To iEcount
.ChartData.Workbook.Sheets(1).Cells(1 + y, 2) = xData.Cells(lDataRow, (lEstartCol - 1) + y)
Next y
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("G").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 11) * 100
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("K").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 13) * 100
.Refresh
.ChartData.Workbook.Close
End With
End With
'increment slide & row indices
lSldNum = lSldNum + 1
lDataRow = lDataRow + 1
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
Next Slide
myPres.Slides(1).Select 'return to starting position
GoTo Success
Success:
'Write to log file
Call LogFile_Write(wb.Path, "LoadDashboards", "SUCCESS", numNames & " names' data loaded")
myPres.SaveAs Filename:=wb.Path & "\" & ProjectName & ".pptx"
'Notify user
AppActivate Application.Caption
MsgBox "Data loaded successfully.", vbSystemModal + vbInformation
Exit Sub
Failure:
'write to log file
Call LogFile_Write(wb.Path, "LoadDashboards", "ERROR", errArea & " - " & Err.Number & " - " & Err.Description)
'Notify user
AppActivate Application.Caption
MsgBox "An error occurred. Please try again.", vbSystemModal + vbCritical, "Error"
Exit Sub
End Sub
Public Function CleanData()
On Error GoTo Failure
Dim x As Integer 'Rows
Dim y As Integer 'Cols
For y = 3 To LastCol
Select Case y
'Round raw data to 2 decimal places
Case 5, 6, 7, 9, 11, 13 'E attributes data first, then E average
For x = FirstRow To LastRow
xData.Cells(x, y) = Application.WorksheetFunction.Round(xData.Cells(x, y), 2)
Next x
End Select
Next y
Exit Function
Failure:
'Write to log file
Call LogFile_Write(wb.Path, "CleanData", "ERROR", " - " & Err.Number & " - " & Err.Description)
'Notify user
AppActivate Application.Caption
MsgBox "An error occurred. Please try again.", vbSystemModal + vbCritical, "Error"
End Function
Public Function GetOpenOrClosedPPT(ByVal sTargetFullName As String) As Object
Dim funcPPTApp As Object
Dim p As PowerPoint.Presentation
On Error Resume Next
Set funcPPTApp = GetObject(, "PowerPoint.Application") 'Check if PPT is running
PPTisOpen:
If Not (funcPPTApp Is Nothing) Then 'If PPT is running
For Each p In funcPPTApp.Presentations 'For all open Presentations
If p.FullName = sTargetFullName Then 'If name matches target Presentation
Set GetOpenOrClosedPPT = p 'Set function result to Presentation
Exit Function
End If
Next p
GoTo PPTisNotOpen 'If PPT is running but file is not open
End If
PPTisNotOpen:
Set funcPPTApp = CreateObject("PowerPoint.Application")
funcPPTApp.Presentations.Open (sTargetFullName) 'Open target Presentation
Set GetOpenOrClosedPPT = funcPPTApp.Presentations(sTargetFullName) 'Set function result to Presentation
End Function
Public Function LogFile_Write( _
ByVal sPath As String _
, ByVal sProcedure As String _
, ByVal sType As String _
, ByVal sDescription As String)
Dim sFilePath As String
sFilePath = sPath & "\debug_log.txt" 'logfile path
Dim sText As String
On Error GoTo ErrorHandler
If (g_objFSO Is Nothing) Then
Set g_objFSO = New FileSystemObject 'Initialize var
End If
If (g_scrText Is Nothing) Then
If (g_objFSO.FileExists(sFilePath) = False) Then 'If logfile does not already exist, create one
Set g_scrText = g_objFSO.OpenTextFile(sFilePath, IOMode.ForWriting, True)
sText = "File created:" & Format(Date, "DD MMM YYYY") & vbCrLf
Else
Set g_scrText = g_objFSO.OpenTextFile(sFilePath, IOMode.ForAppending)
End If
End If
'Append new line to existing text
sText = sText & "- " & _
sProcedure & " " & _
sType & ": " & _
Format(Date, "DD MMM YYYY") & "-" & _
Time() & " || " & _
sDescription
g_scrText.WriteLine sText
g_scrText.Close
Set g_scrText = Nothing
Exit Function
ErrorHandler:
Set g_scrText = Nothing
Call MsgBox("Unable to write to log file", vbCritical, "LogFile_Write")
End Function

Answer 1

Try sleep command of windows. (sleep will pause the code for sometime)
To let charts sometime to refresh.
Type below line on top of the program:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
In the code, after updating the charts and before closing the chart workbook,
Type:
sleep 5000
5000 is for 5 seconds, you can modify for your choice.
Regards,
Balu.