內存不足的Excel VBA

Question

我已經取得了一些子程序和他們在測試階段的5檔偉大的工作，但是當我把他們對真實數據的工作，即600個文件，一段時間後，我得到這個消息：

Excel無法用可用資源完成此任務。選擇更少的數據或關閉其他應用程序。

我GOOGLE了它，我發現最是application.cutcopymode = false，但在我的代碼我沒有使用剪切和複製模式，但處理與

destrange.Value = sourceRange.Value 

複製而當我去調試，我的意思是在錯誤提示後，它將我帶到同一行代碼中。如果有人遇到類似的情況，並知道如何解決這個問題，我將不勝感激。

只是爲了讓自己清楚我已經試過application.cutcopymode = false並沒有幫助。我打開這600個文件中的每一個，按照不同的標準排序，並從每個拷貝的前100個拷貝到一個新的工作簿（一個接一個），當我完成一個標準時，我保存並關閉新的工作簿並打開新的並繼續提取數據不同的標準。

如果有人有興趣幫助，我也可以提供代碼，但爲了簡單的問題我沒有。任何幫助或建議都是值得歡迎的。謝謝。

編輯：

這裏主要分：（它的目的是從工作簿中的信息承擔多少第一行復制，因爲我需要一次複製第一個100，然後50，然後20，然後10 ...）

Sub final() 
Dim i As Integer 
Dim x As Integer  

For i = 7 To 11 

    x = ThisWorkbook.Worksheets(1).Range("N" & i).Value   

    Maximum_sub x 
    Minimum_sub x 
    Above_Average_sub x 
    Below_Average_sub x 

Next i 

End Sub 

這裏是該潛艇之一：（其他都基本相同，只是排序標準的變化）

Sub Maximum_sub(n As Integer) 
    Dim MyPath As String, FilesInPath As String 
    Dim MyFiles() As String 
    Dim SourceRcount As Long, FNum As Long 
    Dim mybook As Workbook, BaseWks As Worksheet 
    Dim sourceRange As Range, destrange As Range 
    Dim rnum As Long 
    Dim srt As Sort   

    ' The path\folder location of your files. 
    MyPath = "C:\Excel\"  

    ' If there are no adequate files in the folder, exit. 
    FilesInPath = Dir(MyPath & "*.txt") 
    If FilesInPath = "" Then 
     MsgBox "No files found" 
     Exit Sub 
    End If 

    ' Fill the myFiles array with the list of adequate files 
    ' in the search folder. 

    FNum = 0 
    Do While FilesInPath <> "" 
     FNum = FNum + 1 
     ReDim Preserve MyFiles(1 To FNum) 
     MyFiles(FNum) = FilesInPath 
     FilesInPath = Dir() 
    Loop 

    'get a number: take a top __ from each 
    'n = ActiveWorkbook.Worksheets(1).Range("B4").Value 

    ' Add a new workbook with one sheet. 
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 

    rnum = 1 

    ' Loop through all files in the myFiles array. 
    If FNum > 0 Then 
     For FNum = LBound(MyFiles) To UBound(MyFiles) 

      Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) 


      ' Change this to fit your own needs. 

      ' Sorting 
      Set srt = mybook.Worksheets(1).Sort 

      With srt 
       .SortFields.Clear 
       .SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlDescending 
       .SetRange Range("A1:C18000") 
       .Header = xlYes 
       .MatchCase = False 
       .Orientation = xlTopToBottom 
       .SortMethod = xlPinYin 
       .Apply 
      End With 

      'Deleting nulls 
      Do While (mybook.Worksheets(1).Range("C2").Value = "null") 
      mybook.Worksheets(1).Rows(2).Delete 
      Loop     

      Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1) 

      SourceRcount = sourceRange.Rows.Count 

      Set destrange = BaseWks.Range("A" & rnum) 

      BaseWks.Cells(rnum, "A").Font.Bold = True 
      BaseWks.Cells(rnum, "B").Font.Bold = True 
      BaseWks.Cells(rnum, "C").Font.Bold = True   

      Set destrange = destrange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)   

      destrange.Value = sourceRange.Value 

      rnum = rnum + SourceRcount 

      mybook.Close savechanges:=False 

     Next FNum 
     BaseWks.Columns.AutoFit 

    End If 

    BaseWks.SaveAs Filename:="maximum_" & CStr(n) 
    Activewoorkbook.Close 

End Sub 

Answer 1

。你的最後一欄後Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1)會選擇所有空列，並炸燬你的記憶

爲了使這更動態的插入（沒有測試）

sub try() 
dim last_col_ad as string 
dim last_col as string 

last_col_ad = mybook.Worksheets(1).Range("XFD1").End(xlLeft).Address 
last_col = Replace(Cells(1, LastColumn).Address(False, False), "1", "") 

Set SourceRange = mybook.Worksheets(1).Range("A2:" & last_col & n + 1) 

end sub