運行兩次內存時出現內存不足的問題

Question

我是這個論壇的新手，但最近我一直在閱讀大量的帖子，因爲我目前正在自學VBA的工作中使用！

我目前遇到了一些我已經創建的代碼的問題。代碼的目的是根據雙擊單元格值自動篩選多個工作表，然後將這些過濾的結果複製到另一個「主報表」工作表。問題是它一次運行得很好，在此之後，如果我嘗試再次運行它或者在工作簿中運行其他任何宏，會彈出一個錯誤，要求我關閉內存以釋放內存！

我試着運行一次宏，保存並關閉工作簿（清除任何可能被緩存的內容），重新打開並運行，但同樣的錯誤仍然存​​在。我也試圖改變我的。選擇與.activate提示所建議：

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

試試你的代碼的這個重構

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 

應該爲你工作，因爲它在我的測試中表現的話，我可以加你一些信息，如果你關心

Answer 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 

這是我沒有辦法完成，並且會在我找到位的時候進行編輯，但是一個開始減少宏觀壓力的好地方。