通过VBA创建图表-没有足够的内存来完成此操作

Question

我有一个Excel宏，可以为每行创建一个自定义图表。

我的意图是每次运行宏时都创建约50,000个图表。在遇到错误之前，我只能通过大约3,000-5,000：

“没有足够的内存来完成此操作。请尝试使用较少的数据或关闭其他应用程序。要提高内存可用性，请考虑使用64位版本的Microsoft Excel。”

开始时，代码每秒创建大约一张图表。当它进入成百上千的速度时，它的速度大大降低。

在崩溃之前和崩溃即将发生的时候，我从任务管理器中看到，只有10％的CPU和15％的RAM被利用-远远没有我认为引起这种内存问题的必要程度。

出现错误时，通常会保存并关闭Excel，重新打开工作簿，然后再次运行正常。因此，我放入了一些代码，该代码每隔1,000个图表停止一次，然后保存该工作簿，然后再继续。这根本没有帮助。

关于我的系统和设置的一些注意事项：

• 我正在具有64 GB RAM的专用Windows 2016服务器上运行此服务器（确切的服务器规格在这里：https://turnkeyinternet.net/dedicated-servers/dedicated-server-dual-hexacore-64gb/）
• 我正在运行64位Excel 2016
• 我尝试运行此宏时没有其他程序在运行（当然，除了其他必要的后台进程和Outlook会话以外）
• 我已禁用所有COM加载项，Excel加载项和Outlook加载项
• 我已将计算设置为手动

代码如下：

Sub CHARTS()

'Turning off non-essential functions
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

'Counting how many rows of data in the Import sheet
' (corresponding to how many charts are generated)
Dim lngRow As Long
lngRow = Worksheets("Import").Cells(Rows.Count, "A").End(xlUp).Row

'Variables to operate the macro
Dim Counter As Integer

'Variables to sub into the template
Dim DataField1 As String
Dim DataField2 As String
Dim DataField3 As String
Dim Recipient As String

'Variables to create and copy the custom chart
Dim DataObj As Shape
Dim objChart As chart
Dim folderpath As String
Dim picname As String
Dim ws As Worksheet
Dim chart As Picture

'Variables to Find & Replace in the template
Dim strFind As String
Dim strNew As String
Dim imgSrc As String

'Data starts at row 2, below headers... Goes to the last row of the sheet
For Counter = 2 To lngRow

    'Pulls the values from their cells in the Import sheet
    DataField1 = Worksheets("Import").Cells(Counter, 24)
    DataField2 = Worksheets("Import").Cells(Counter, 1)
    DataField3 = Worksheets("Import").Cells(Counter, 5)
    Recipient = Worksheets("Import").Cells(Counter, 17)

    'Pastes the values from into the Chart sheet to create the custom chart
    Worksheets("Chart").Cells(1, 2) = DataField1
    Worksheets("Chart").Cells(2, 2) = DataField2
    Worksheets("Chart").Cells(6, 2) = DataField3

    'Updates the chart area, since calculation is set to manual mode
    Worksheets("Chart").Columns("A:J").Calculate

    Set ws = Worksheets("Chart")

    'Locating & assigning current folder path of Excel file,
    ' then setting the name for the chart image based on DataField1
    folderpath = Application.ActiveWorkbook.Path & Application.PathSeparator
    picname = DataField1 & ".jpg"

    'Copying the chart range as an image
    ActiveWindow.DisplayGridlines = False
    On Error GoTo ErrHandler3:
    Call ws.Range("H6:AB26").CopyPicture(xlPrinter, xlPicture)

    'Creates a new sheet called Image, then adds the chart image,
    ' sets the height/width, then exports it to the folder with its name

    'creating a new sheet to insert the chart
    Worksheets.Add(after:=Worksheets(1)).Name = "Image"

    ActiveSheet.Shapes.AddChart.Select
    Set objChart = ActiveChart

    'making chart size match image range size
    ActiveSheet.Shapes.Item(1).Width = ws.Range("H6:AB26").Width

    ActiveSheet.Shapes.Item(1).Height = ws.Range("H6:AB26").Height
    objChart.Paste
    objChart.Export (folderpath & picname) 

    'Deletes the Image sheet
    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete 'deleting sheet 'Image'
    Application.DisplayAlerts = True

Next Counter

'Turn back on essential functions
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

'Send myself an email to let me know that its finished (I never get to this part)
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItemFromTemplate("C:\Users\Administrator\CHARTS\DONE.oft")
oMail.Send

MsgBox "Done"

End Sub

Answer 1

将DoEvents代码放入您的for循环几次。

https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/doevents-function

这将允许您的处理器执行某些任务，这会使您的代码花费更长的时间，但应避免出现完整的内存情况：）

Answer 2

将Set oApp = CreateObject("Outlook.Application")放置在For循环之外。

Answer 3

我一直无法找到解决内存泄漏的解决方案，所以我改用PHP而不是excel来生成图表。