内存缺乏Excel VBA
我已经做了一些子程序，他们在5个文件的testing阶段工作得很好，但是当我把它们放在真正的数据上时，那就是600个文件，一段时间之后，我得到这个消息：
Excel无法使用可用资源完成此任务。 select更less的数据或closures其他应用程序。
我GOOGLE了它，我发现最多的是application.cutcopymode = false ，但在我的代码，我不使用剪切和复制模式，但处理复制
destrange.Value = sourceRange.Value
而当我去debugging，我的意思是在错误提示后，我需要这一行代码。 如果有人遇到类似的情况，并知道如何解决这个问题，我将不胜感激。
只是为了让自己清楚我已经尝试了application.cutcopymode = false并没有帮助。 我打开这600个文件中的每一个，按照不同的标准sorting，从每个拷贝开始，先将100个拷贝到新的工作簿中（一个接一个），当我完成一个标准时，我保存并closures新的工作簿并打开新的工作簿，不同的标准。
如果有人有兴趣帮忙，我也可以提供代码，但为了简单起见，我没有。 任何帮助或build议都是值得欢迎的。 谢谢。
编辑：
这里是主要的子目录:(其目的是从工作簿信息中获取复制的第一行数，因为我需要先复制第一个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
这里是其中的一个：（其他人基本上是一样的，只是对标准进行sorting。）
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
Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1)将select你最后一列之后的所有空列，并炸掉你的记忆
为了使这个更dynamic的插入（ 未testing ）
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