excel - 宏运行两次时内存不足

Question

我是这个论坛的新手，但最近一直在阅读大量帖子，因为我目前正在自学 VBA 以供在工作中使用!

我目前对我创建的一些代码有疑问。该代码的目的是根据双击的单元格值自动过滤多个工作表，然后将这些过滤结果复制到另一个“主报告”工作表。问题是它运行一次非常好，之后如果我尝试再次运行它或工作簿中的任何其他宏，则会弹出一个错误，要求我关闭一些东西以释放内存!

我曾尝试运行一次宏，保存并关闭工作簿(以清除可能缓存的任何内容)，重新打开并运行，但仍然存在相同的错误。我还尝试按照以下建议使用 .activate 更改我的 .select 提示:

How to avoid running out of memory when running VBA

但这似乎破坏了我的代码......然后我可能只是错误地实现了它，因为我有点 VBA noob 谁能帮我优化我的代码以防止这种情况？

我的代码如下:

Private Sub Merge()
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Selection.Merge
End Sub

-------------------------------------------------------------------------------------------------------------------------------------------------------

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("Master Report").Cells.Delete 'clear old master report
Column = Target.Column
Row = Target.Row

'this automatically filters information for a single part and creates a new master report with summary information
PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms
    With Worksheets("NCR's") 'filter NCR sheet
        .Select
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
    End With
Sheets("NCR's").Select
Sheets("NCR's").Range("A3:K3").Select
Sheets("NCR's").Range(Selection, Selection.End(xlDown)).Select 'select NCR filtered summary info
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("A1").Formula = PartNumber
Sheets("Master Report").Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
Sheets("Master Report").Range("A4").Select
ActiveSheet.Paste 'paste filtered NCR info into master report
Sheets("Master Report").Range("A3:K3").Select
Call Merge
ActiveCell.FormulaR1C1 = "NCR's"

With Worksheets("CR's") 'filter CR sheet
        .Select
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=3, Criteria1:=PartNumberWildCard
    End With
Sheets("CR's").Select
Sheets("CR's").Range("A7:F7").Select
Sheets("CR's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
Sheets("Master Report").Range("P4").Select
ActiveSheet.Paste
Sheets("Master Report").Range("RP3:U3").Select
Call Merge
ActiveCell.FormulaR1C1 = "CR's"

With Worksheets("PO's") 'filter PO sheet
        .Select
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
    End With
Sheets("PO's").Select
Sheets("PO's").Range("A3:H3").Select
Sheets("PO's").Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Master Report").Select
lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row
lastRow = lastRow + 3
Sheets("Master Report").Range("A" & lastRow).Select
ActiveSheet.Paste
Sheets("Master Report").Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
Call Merge
ActiveCell.FormulaR1C1 = "PO's"
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

可能有帮助的另一条信息是，我尝试删除三个过滤/复制/粘贴例程中的最后一个，这使我可以运行代码大约 3 次，然后再遇到相同的内存错误。此外，调试器总是卡在宏开始时清除主报告的命令上

Sheets("Master Report").Cells.Delete 'clear old master report

Answer 1

有一些技巧可以加快你的宏并使其使用更少的内存(更少的选择、复制粘贴)。首先，最好循环浏览您的工作表，而不是为每个工作表编写一个长脚本。

Dim arrShts As Variant, arrSht As Variant
arrShts = Array("NCR's", "CR's", "PO's")
For Each arrSht In arrShts
    Worksheets(arrSht).Activate
    'rest of your code'
Next arrSht

在数组中添加运行脚本所需的任何其他工作表

还建议声明变量:

Dim masterws As Worksheet
Set masterws = Sheets("Master Report")

masterws.Activate
masterws.Range("A1").Formula = PartNumber

我无法 100% 准确地做到这一点，但您可以将代码限制为以下内容

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Application.ScreenUpdating = False
Application.EnableEvents = False
Column = Target.Column
Row = Target.Row

PartNumber = Cells(Row, 2).Value 'capture target part number for filtering
PartDesc = Cells(Row, 7).Value 'capture target part description
PartNumberWildCard = "*" & PartNumber & "*" 'add wildcards to allow for additional terms

Dim arrShts As Variant, arrSht As Variant, lastrw As Integer
Dim masterws As Worksheet
Set masterws = Sheets("Master Report")

masterws.Cells.Clear 'clear old master report
arrShts = Array("NCR's", "CR's", "PO's")

For Each arrSht In arrShts
    Worksheets(arrSht).Activate
    lastrw = Sheets(arrSht).Range("K" & Rows.Count).End(xlUp).Row
    With Worksheets(arrSht) 'filter NCR sheet
        On Error Resume Next
        ActiveSheet.ShowAllData 'remove any previous filters
        On Error GoTo 0
        .Range("A1").AutoFilter Field:=2, Criteria1:=PartNumberWildCard
    End With

    Range(Cells(3, 1), Cells(lastrw, 11)).Copy
    lastRow = Sheets("Master Report").Range("A" & Rows.Count).End(xlUp).Row

    masterws.Activate
    masterws.Range("A1").Formula = PartNumber
    masterws.Range("D1").Formula = PartDesc 'Print part no. & description at top of master report
    masterws.Range("A" & lastRow).PasteSpecial xlPasteValues
    masterws.Range("A" & lastRow - 1 & ":H" & lastRow - 1).Select
    Call Merge
    ActiveCell.FormulaR1C1 = arrSht
    Application.CutCopyMode = False
Next arrSht

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

这绝不是完整的，并且会在我找到位时进行编辑，但是一个开始减少宏压力的好地方。