宏运行两次时内存不足

Question

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

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

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

How to avoid running out of memory when running VBA

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

我的代码如下：

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

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

Answer 2

尝试重构您的代码

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
    Dim iRow As Long
    Dim PartNumber As String, PartDesc As String, PartNumberWildCard As String
    Dim masterSht As Worksheet

    Set masterSht = Worksheets("Master Report")

    cancel = True
    iRow = Target.Row

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

    'clear old master report and write headers
    With masterSht
        .Cells.ClearContents
        .Cells.UnMerge
        .Range("A1").Value = PartNumber
        .Range("D1").Value = PartDesc 'Print part no. & description at top of master report

        FilterAndPaste "NCR's", "K1", 2, PartNumberWildCard, .Range("A4")

        FilterAndPaste "CR's", "F1", 3, PartNumberWildCard, .Range("P4")

        FilterAndPaste "PO's", "H1", 2, PartNumberWildCard, .Cells(rows.count, "A").End(xlUp).Offset(3)
    End With
End Sub


Sub FilterAndPaste(shtName As String, lastHeaderAddress As String, fieldToFilter As Long, criteria As String, targetCell As Range)
    With Worksheets(shtName)
        .AutoFilterMode = False 'remove any previous filters
        With .Range(lastHeaderAddress, .Cells(.rows.count, 1).End(xlUp))
            .AutoFilter Field:=fieldToFilter, Criteria1:=criteria
            If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
                .Resize(.rows.count - 1).Offset(1).SpecialCells(XlCellType.xlCellTypeVisible).Copy Destination:=targetCell
                With targetCell.Offset(-1).Resize(, .Columns.count)
                    Merge .Cells
                    .Value = shtName
                End With
            End If
        End With
    End With
End Sub

Private Sub Merge(rng As Range)
    With rng
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Merge
    End With
End Sub

如果它对你有用，就像我在测试中所做的那样，那么我可以为你添加一些信息，如果你关心的话