Excel 宏运行两次时内存不足

我是这个论坛的新成员，但最近已经阅读了大量帖子，因为我目前正在自学VBA，以便在工作中使用

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

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

但这似乎打破了我的密码。。。再说一次，我可能只是实现了错误，因为我是一个有点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

---

有几个技巧可以加快宏的运行速度，减少内存占用（减少选择、复制和粘贴）。首先，最好在工作表中循环，而不是每个工作表都有一个长脚本

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

---

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

尝试对代码进行重构

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

---

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

我也会在你的宏

应用程序的末尾添加。CutCopyMode=False

，以清除剪贴板。如果你不小心，这可能会导致速度减慢和错误行为。我会尝试一下！我之前没有尝试的唯一原因是，不同的工作表有时需要多个筛选条件，并且信息会粘贴到不同的位置。您在上面粘贴的代码会将信息粘贴到主报告的垂直列表中，这很好，但我不确定如何解决不同数量的过滤标准问题如果是这种情况，您可以根据图纸名称定义不同的过滤标准

，如果arrSht=“NCR”然后PartNumberWildCard=*此工作表的某些内容*

这不是因为partnumbers发生了更改，而是因为为自动筛选定义的字段发生了更改。例如，在NCR中，我只在字段2中过滤，但在PO的字段2和3中过滤，您可以将该剪辑修改为适用于您的字段，而不是零件号wildcardhi，这似乎非常有效！我不太明白FilterandPaste sub中发生了什么。它不会将我的标题粘贴到主报告中。另外，我应该如何修改它，以便它在字段2或3中搜索采购订单工作表中的零件号？我知道了如何包含标题，但仍然不确定这部分代码：

If Application.WorksheetFunction.Subtotal（103，.Resize（，1））>1，然后.Resize（.Rows.Count-1）。SpecialCells（XlCellType.xlCellTypeVisible）。复制目标：=带有targetCell.Offset（-1）的targetCell。调整大小（，.Columns.Count）