内存不足的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