VBA 从 Excel 更新现有的 PPT 图表 - 内存过多？答案

【问题标题】：VBA update existing PPT charts from Excel - too much memory?VBA 从 Excel 更新现有的 PPT 图表 - 内存过多？
【发布时间】：2021-02-25 16:14:34
【问题描述】：

我已经搜索了几个月来找到我的问题的答案，并认为我已经接近了，但不知道如何纠正它。我所有的 VBA 知识都来自 Google、Stack Overflow 和各种论坛，所以请原谅我的代码状态。

总体目标： 我有一个 PPT 模板文件，其中包含 1 张模板幻灯片，其中包含几个充满“虚拟”数据的图表，格式完全符合我的需要。我还有一个 Excel 主文件，其中包含特定工作表上的数据（也包含 VBA）。我需要为numNames 数据行复制模板幻灯片，然后在每张幻灯片上使用每行中包含的真实数据填充图表（和其他项目）。

问题：

此代码在规模上的可靠性非常低。此代码适用于 numNames
有时图表会在填充数据后“消失”，从而导致以后的 subs 出现错误。这可能发生在任何幻灯片上的任何圆形图上。我添加了.Refresh 和.DoEvents 来解决这个问题，但无济于事。 Missing Graph
如果我太快地填充图表，PPT 会占用大量可用内存，我认为这会导致我的一些头痛（因此Application.Wait）。我使用的是运行 64 位 Excel/PPT 的工作笔记本电脑，大多数时候可用的 RAM 约为 4GB。循环内的峰值 PPT 内存使用量约为 1.3GB。不知道这里发生了什么。

我尝试了Application.ScreenUpdating = false，它有点帮助，但上述问题仍然存在。

我相信我所有的问题都源于我如何用真实数据填充这些图表，但到目前为止我还没有找到更好的解决方案。我正在寻找有关如何以更好/更快的方式填充这些图表的任何建议，或者通常清理此代码以使其运行更顺畅。谢谢。

如果你想跳过这个 sub 的设置部分，只需 ctrl+F '$

*这里有些代码不是我自己写的，不是我亲自写的代码

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

【问题讨论】：

如果您认为 Application.Wait 引起了问题，我建议您在此处使用延迟功能将其换掉：stackoverflow.com/questions/49389093/…
@Tragamor 我之前的措辞可能令人困惑。我不认为 Application.Wait 会导致任何问题 - 这本来是解决我的问题的创可贴，但它并不能解决所有问题。
在 PPT 中没有过多使用图表，但您可以考虑在 Excel 文件中创建图表，然后在 PPT 中复制图片 >> 粘贴、大小、位置。似乎在 PPT 中使用基础图表工作表可能会有很大的开销，您可以通过使用粘贴的图形来避免（除非您真的需要“实时”图表？）
@TimWilliams 我以前也走过这条路，不幸的是，“实时”图表是我唯一可以接受的解决方案。

标签： excel vba loops charts powerpoint

【解决方案1】：

试试 windows 的 sleep 命令。（sleep 会暂停代码一段时间）让图表有时间刷新。

在程序顶部的下面一行输入：

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

在代码中，更新图表后关闭图表工作簿之前，类型：

sleep 5000

5000是5秒，你可以随意修改。

问候，巴鲁。

【讨论】：