Running out of VBA Memory

问题

Im running the code below, which does exactly what I want it to. The issue I am having with it though is that when I keep the sheet running for a period of time like 10 min I get a pop up error message saying I have run out of memory.

Is there something I could put in my code that I could use to prevent this?

My code is as below,

Sub auto_open()
    Call ScheduleCopyPriceOver
End Sub


Sub ScheduleCopyPriceOver()
    TimeToRun = Now + TimeValue("00:00:10")
    Application.OnTime TimeToRun, "CopyPriceOver"
End Sub

Sub CopyPriceOver()
Dim lRow    As Long
Dim ws      As Worksheet

Set ws = ThisWorkbook.Sheets("Orders")


Application.ScreenUpdating = False



    For SRow = 1 To 5000
    If ws.Cells(SRow, 19) = SRow Then
        ws.Cells(SRow, 12).Select
        ActiveCell.FormulaR1C1 = "ready"
        Call ScheduleCopyPriceOver

     ElseIf ws.Cells(SRow, 20) = SRow Then
        ws.Cells(SRow, 12).Select
        ActiveCell.FormulaR1C1 = "cancel"


    End If
    Next

    Call ScheduleCopyPriceOver



End Sub

Sub auto_close()
    On Error Resume Next
    Application.OnTime TimeToRun, "CopyPriceOver", , False
End Sub

回答1:

Your overflow is almost certainly being caused by so many scheduled events.

In your loop, you are scheduling an OnTime if any row has the row number as a value in column S. You are then also scheduling one more OnTime even if no rows have the row number in column S.

So, if 200 of your 5000 rows have a matching value, you will be setting 201 scheduled calls to the macro in 10 seconds time. When those 201 events fire, they might (depending on what has happened within that 10 seconds) generate another 40000+ events. (Even if there was only one row with column S's value matching the row number, after 10 minutes you would end up with over 1,000,000,000,000,000,000 events being queued.)

There is no need to reschedule the CopyPriceOver code more than once, so remove the Call ScheduleCopyPriceOver from within the loop.

For SRow = 1 To 5000
    If ws.Cells(SRow, 19).Value = SRow Then

        ws.Cells(SRow, 12).FormulaR1C1 = "ready"
        'Get rid of the next line
        'Call ScheduleCopyPriceOver

    ElseIf ws.Cells(SRow, 20).Value = SRow Then

        ws.Cells(SRow, 12).FormulaR1C1 = "cancel"

    End If
Next

Call ScheduleCopyPriceOver

来源：https://stackoverflow.com/questions/43273299/running-out-of-vba-memory

标签

excel

vba

excel-vba