当运行两次的macros内存不足
我是这个论坛的新手，但是现在我正在自学VBA在工作中使用，所以最近阅读了大量的post！
我目前遇到了一些我已经创build的代码的问题。 代码的目的是根据双击的单元格值自动筛选多个工作表，然后将这些过滤的结果复制到另一个“主报表”工作表。 问题是，它一次运行得很好，之后如果我再次运行它或者我的其他macros在工作簿中，会popup一个错误，要求我closures内存以释放内存！
我曾尝试运行一次macros，保存和closures工作簿（清除任何可能被caching），重新打开并运行，但同样的错误仍然存在。 我也尝试改变我的.select提示与.activatebuild议由：
运行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 另一个可能有帮助的信息是，我尝试删除三个filter/复制/粘贴例程中的最后一个，这使我运行代码大约3次，然后运行到相同的内存错误。 此外，debugging器总是卡在命令清除macros开始的主报告
Sheets("Master Report").Cells.Delete 'clear old master report
尝试重构你的代码
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
如果它对你有用，就像在我的testing中那样，那么我可以给你添加一些信息，如果你关心的话
有几个技巧来加快你的macros，使其使用较less的内存（lessselect，复制粘贴）。 一开始，最好是循环你的表格，而不是每一个长的脚本。
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
在数组中添加您需要运行脚本的任何其他工作表
也build议声明variables：
Dim masterws As Worksheet Set masterws = Sheets("Master Report") masterws.Activate masterws.Range("A1").Formula = PartNumber
我无法准确地做到这一点，但是可以将代码限制在如下所示的范围内
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
这是没有办法完成，并会编辑，因为我发现位，但一个好地方开始减less你的macros的压力。