运行两次时宏耗尽内存

时间：2016-11-16 15:55:41

标签： excel vba memory optimization

我是这个论坛的新手，但最近一直在阅读大量的帖子，因为我目前正在教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

2 个答案:

答案 0 :(得分：2)

有一些提示可以加快宏的速度并减少内存使用（减少选择，复制粘贴）。首先，最好循环使用工作表，而不是每个工作表都有一个长脚本。

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

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

答案 1 :(得分：1)

尝试重构代码

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

它应该对你有用吗，就像在我的测试中一样，然后我可以添加一些信息，如果你关心

相关问题
最新问题